module LambdaSKI

-- Based on http://okmij.org/ftp/tagless-final/ski.pdf

data HasType : List a -> a -> Type where
  VZ : HasType (t :: env) t
  VS : HasType env t -> HasType (_ :: env) t

data Expr : List Type -> Type -> Type where
  Var : HasType env t -> Expr env t
  Lam : Expr (a :: env) b -> Expr env (a -> b)
  App : Expr env (a -> b) -> Expr env a -> Expr env b

data SKI : Type -> Type where
  KI : SKI (a -> a)
  KK : SKI (a -> b -> a)
  KS : SKI ((a -> b -> c) -> (a -> b) -> a -> c)
  KB : SKI ((a -> b) -> (c -> a) -> c -> b)
  KC : SKI ((a -> b -> c) -> b -> a -> c)
  KApp : SKI (a -> b) -> SKI a -> SKI b

data Repr : List Type -> Type -> Type where
  C : SKI a -> Repr env a
  N : Repr env (a -> b) -> Repr (a :: env) b
  W : Repr env a -> Repr (_ :: env) a

app : Repr env (a -> b) -> Repr env a -> Repr env b
app (C x) (C y) = C $ KApp x y
app (C x) (N y) = N $ app (C (KApp KB x)) y
app (C x) (W y) = W $ app (C x) y
app (N x) (C y) = N $ app (C  (KApp (KApp KC KC) y)) x
app (N x) (N y) = N $ app (app (C KS) x) y
app (N x) (W y) = N $ app (app (C KC) x) y
app (W x) (C y) = W $ app x (C y)
app (W x) (N y) = N $ app (app (C KB) x) y
app (W x) (W y) = W $ app x y

conv : Expr env a -> Repr env a
conv (Var VZ) = N $ C KI
conv (Var (VS x)) = W $ conv (Var x)
conv (Lam x) with (conv x)
  conv (Lam x) | (C y) = C $ KApp KK y
  conv (Lam x) | (N y) = y
  conv (Lam x) | (W y) = app (C KK) y
conv (App f x) = app (conv f) (conv x)

comp : Expr [] a -> SKI a
comp expr with (conv expr)
  comp expr | (C x) = x

example : Expr [] ((() -> ()) -> () -> ())
example = Lam (Lam (App (Var (VS VZ)) (Var VZ)))

test : SKI ((() -> ()) -> () -> ())
test = comp example


module Ch05.LambdaCalculusWithArith

import Ch03.Relations

%default total
%access public export

--------------------------------------------------------------------------------
-- The lambda calculus extended by native arithmetic expressions.
--------------------------------------------------------------------------------
--
-- Remark: It kinda sucks to have to repeat the definitions of the lambda
-- calculus and the language of arithmetic expressions. In particular because
-- in the book Pierce doesn't even bother to write down the language and simply
-- waves his hands. So you expect to be able to just formally combine the two
-- languages.
-- However, I don't know a convenient way to do that since Idris has no subtyping.
-- It would be possible to define something like
--
-- data Term = Lambda Ch05.LambdaCalculus.Term
--           | Arith Ch03.Arith.Term
--
-- but that would be kinda awkward.
--
-- TL;DR: I'm just gonna repeat definitions as that seems simpler.
--------------------------------------------------------------------------------

||| The type of variables
Variable : Type
Variable = Nat

-- Pierce doesn't bother to actually define this calculus (neither in the book
-- nor the software available at https://www.cis.upenn.edu/~bcpierce/tapl).
-- So I'm using the simplest, most naive definition I can imagine here.
||| Terms in the lambda calculus extended by arithmetic expressions.
data Term = True
          | False
          | IfThenElse Term Term Term
          | Zero
          | Succ Term
          | Pred Term
          | IsZero Term
          | Var Variable
          | Abs Variable Term
          | App Term Term

||| Convenient infix notation for construction of function application terms
(.) : Term -> Term -> Term
(.) = App

-- TODO: Can we get rid of the argument `n`?
||| Convenience function for constructing lambda terms
lambda : Nat -> (Term -> Term) -> Term
lambda n f = Abs n (f (Var n))

-----------------------------------------------------------------------
-- The stuff below is literally copy pasted from Ch05.LambdaCalculus

--------------------------------------------------------------------------------
-- Booleans
--------------------------------------------------------------------------------

||| The Church boolean true
tru : Term
tru = Abs 1 (Abs 0 (Var 1))

||| The Church boolean false
fls : Term
fls = Abs 1 (Abs 0 (Var 0))

||| Church encoding of the if-then-else operator
test : Term
test = Abs 2 (Abs 1 (Abs 0 (App (App (Var 2) (Var 1)) (Var 0))))

||| Logical AND operator for Church booleans.
and : Term
and = Abs 0 (Abs 1 (App (App (Var 0) (Var 1)) fls))

--------------------------------------------------------------------------------
-- Pairs
--------------------------------------------------------------------------------

||| Church pair constructor
pair : Term
pair = Abs 0 (Abs 1 (Abs 2 (App (App (Var 2) (Var 0)) (Var 1))))

||| Projection onto the first component of a pair
fst : Term
fst = Abs 0 (Abs 1 (Var 0))

||| Projection onto the second component of a pair
snd : Term
snd = Abs 0 (Abs 1 (Var 1))

--------------------------------------------------------------------------------
-- Numerals
--------------------------------------------------------------------------------

||| The Church numeral zero.
church_zero : Term
church_zero = Abs 1 (Abs 0 (Var 0))

||| The Church numeral one.
church_one : Term
church_one = Abs 1 (Abs 0 (App (Var 1) (Var 0)))

||| The Church numeral two.
church_two : Term
church_two = Abs 1 (Abs 0 (App (Var 1) (App (Var 1) (Var 0))))

||| The successors function for Church numerals
scc : Term
scc = Abs 0 (Abs 1 (Abs 2 (App (Var 1) (App (App (Var 0) (Var 1)) (Var 2)))))

||| Addition of Church numerals
plus : Term
plus = Abs 0 (Abs 1 (Abs 2 (Abs 3 ((Var 0) . (Var 2)) . (((Var 1) . (Var 2)) . (Var 3)))))

||| Multiplication of Church numerals
times : Term
times = Abs 0 (Abs 1 ((Var 0) . (plus . (Var 1))) . church_zero)

||| Tests whether a Church numeral is zero or not
iszro : Term
iszro = Abs 0 ((Var 0) . (Abs 0 fls)) . tru

||| The predecessor function on Church numerals
prd : Term
prd = let zz = pair . church_zero . church_zero
          ss = Abs 0 (pair . (snd . (Var 0)) . (scc . (snd . (Var 0)))) in
          Abs 0 (fst . ((Var 0) . ss) . zz)

--------------------------------------------------------------------------------
-- Lists
--------------------------------------------------------------------------------

-- See Ch05.Exercise_5_2_8

--------------------------------------------------------------------------------
-- Self-replicating terms
--------------------------------------------------------------------------------

||| The (?) simplest self-replicating term in the lambda calculus
omega : Term
omega = let x = Var 0
            f = Abs 0 (x . x) in
            f . f

||| The call-by-value version of the fix-point combinator (i.e. Y combinator)
fix : Term
fix = let f = Var 0
          x = Var 1
          y = Var 2
          t = Abs 1 f . (Abs 2 (x . x . y)) in
          Abs 0 (t . t)

-----------------------------------------------------------------------
-- Copy pasted exercises

||| `sub m n` yields the result of subtracting `n` from `m` (Church numerals).
|||
||| More precisely, it yields the smallest church numeral `z` such that
|||
|||     m <= n+z
sub : Term
sub = let m = Var 0
          n = Var 1 in
          Abs 0 (Abs 1 (n . prd) . m)

||| `le m n` tests whether `m` is less than or equal to `n`
le : Term
le = let m = Var 0
         n = Var 1 in
         Abs 0 (Abs 1 (iszro . (sub . m . n)))

||| Test whether two Church numerals are equal
equal : Term
equal = let m = Var 0
            n = Var 1
            m_le_n = le . m . n
            n_le_m = le . n . m in
            Abs 0 (Abs 1 (and . m_le_n . n_le_m))

-----------------------------------------------------------------------
-- Stuff below is lifted wholesale from exercise 5.2.8

-- Lists are represented by their corresponding fold function. That is, a list
-- [x, y, z] is identified with the function
--
--    f |-> ( c |-> f x (f y (f z c))) )
--
-- Where f is any 2-ary function (since the untyped lambda calculus is untyped, of
-- course we can't talk about arities).

||| The term representing the empty list
nil : Term
nil = Abs 0 (Abs 1 (Var 1))--?nil_rhs

||| The term representing the cons combinator
cons : Term
cons = let car = Var 0 -- not to be confused with the car combinator below
           cdr = Var 1 -- --------------------------- cdr ----------------
           f = Var 2
           c = Var 3 in
           Abs 0 (Abs 1 (Abs 2 (Abs 3 (f . car . (cdr . f . c)))))

||| Checks whether a list is nil
isnil : Term
isnil = let l = Var 0
            f = Abs 1 (Abs 2 fls) in
            Abs 0 (l . f . tru)

||| The term representing the "car" combinator
head : Term
head = let l = Var 0 in
           Abs 0 l . fst . nil

||| The term representing the "cdr" combinator
tail : Term
tail = let l = Var 0
           x = Var 1
           y = Var 2
           f = Abs 1 (Abs 2 pair . (snd . y) . (cons . x . (snd . y)))
           c = pair . nil . nil in
           Abs 0 (fst . (l . f . c))

-----------------------------------------------------------------------
-- Stuff below is not copy pasted.

||| Term representing a function converting Church booleans into "real" booleans.
realbool : Term
realbool = lambda 0
                  (\b => b . True . False)

||| Term representing a function converting "real" booleans to Church booleans.
churchbool : Term
churchbool = lambda 0
                    (\b => IfThenElse b tru fls)

||| Term representing a function of two arguments returning a "real" boolean
||| specifying whether they are equal or not, at least if both arguments provided
||| are Church numerals.
realeq : Term
realeq = lambda 0
                (\m => lambda 1
                              (\n => (equal . m . n) . True . False))

||| Term representing a function converting a Church numeral into a primitive natural number
realnat : Term
realnat = lambda 0
                 (\n => n . (lambda 1 (\x => Succ x)) . church_zero) -- TODO: Rename church_zero to c0 etc.


module Verified.Algebra.Bool

import Classes.Verified
import Prelude.Algebra

%default total

instance Semigroup Bool where
  -- Laziness intereferes with the types
  (<+>) = \b1, b2 => b1 || b2

instance VerifiedSemigroup Bool where
  semigroupOpIsAssociative True _ _ = Refl
  semigroupOpIsAssociative False True _ = Refl
  semigroupOpIsAssociative False False True = Refl
  semigroupOpIsAssociative False False False = Refl

instance Monoid Bool where
  neutral = False

instance VerifiedMonoid Bool where
  monoidNeutralIsNeutralL True = Refl
  monoidNeutralIsNeutralL False = Refl
  monoidNeutralIsNeutralR r = Refl


module TypedContainers.Util.Filter

import Data.List

%default total

public export
0 filterCommutative' :
  {f : a -> Bool} -> {g : a -> Bool} -> (xxs : List a) -> (yys : List a)
  -> (yys = filter f (filter g xxs)) -> (yys = filter g (filter f xxs))
filterCommutative' [] yys p = p
filterCommutative' (x :: xs) yys p =
  case the (DPair Bool (g x ===)) $ MkDPair (g x) Refl of
    MkDPair True p0 => case the (DPair Bool (f x ===)) $ MkDPair (f x) Refl of
      MkDPair True p1 =>
        let p2 : (filter f (x :: filter g xs) = filter f (filter g (x :: xs))) = rewrite p0 in Refl in
        let p3 : (x :: filter f (filter g xs) = filter f (x :: filter g xs)) = rewrite p1 in Refl in
        let p3 : (x :: filter f (filter g xs) = filter f (filter g (x :: xs))) = trans p3 p2 in
        case yys of
          [] impossible
          y :: ys =>
            let (Refl) : (y :: ys = x :: filter f (filter g xs)) = trans p (sym p3) in
            let p4 = filterCommutative' {f, g} xs ys Refl in
            rewrite p1 in rewrite p0 in cong (x ::) p4
      MkDPair False p1 =>
        let p2 : (filter f (x :: filter g xs) = filter f (filter g (x :: xs))) = rewrite p0 in Refl in
        let p3 : (filter f (filter g xs) = filter f (x :: filter g xs)) = rewrite p1 in Refl in
        let p3 : (filter f (filter g xs) = filter f (filter g (x :: xs))) = trans p3 p2 in
        case yys of
          [] impossible
          y :: ys =>
            let p4 : (y :: ys = filter f (filter g xs)) = trans p (sym p3) in
            let p5 = filterCommutative' {f, g} xs (y :: ys) p4 in
            rewrite p1 in p5
    MkDPair False p0 =>
      let p2 : (filter f (filter g (x :: xs)) = filter f (filter g xs)) = rewrite p0 in Refl in
      let p3 : (yys = filter f (filter g xs)) = trans p p2 in
      let p4 = filterCommutative' {f, g} xs yys p3 in
      case the (DPair Bool (f x ===)) $ MkDPair (f x) Refl of
        MkDPair True p5 => rewrite p5 in rewrite p0 in p4
        MkDPair False p5 => rewrite p5 in p4

public export
0 filterCommutative : (filter f (filter g l) = filter g (filter f l))
filterCommutative = filterCommutative' {f, g} l (filter f (filter g l)) Refl

0 filterImplication' :
  {f : a -> Bool} -> {g : a -> Bool}
  -> ((x : a) -> (g x = True) -> (f x = True)) -> (xxs : List a) -> (yys : List a)
  -> (yys = filter f (filter g xxs)) -> (yys = filter g xxs)
filterImplication' p0 [] yys p1 = p1
filterImplication' p0 (x :: xs) yys p1 =
  case the (DPair Bool (g x ===)) $ MkDPair (g x) Refl of
    MkDPair True p2 =>
      let p3 : (filter f (filter g (x :: xs)) = filter f (x :: filter g xs)) = rewrite p2 in Refl in
      let p4 : (filter f (x :: filter g xs) = x :: filter f (filter g xs)) = rewrite (p0 x p2) in Refl in
      let p5 : (yys = x :: filter f (filter g xs)) = trans (trans p1 p3) p4 in
      let p6 : (filter f (filter g xs) = filter g xs) = filterImplication' {f, g} p0 xs (filter f (filter g xs)) Refl in
      let p7 : (yys = x :: filter g xs) = replace {p = \p => yys === x :: p} p6 p5 in
      rewrite p2 in p7
    MkDPair False p2 =>
      let p3 : (filter f (filter g (x :: xs)) = filter f (filter g xs)) = rewrite p2 in Refl in
      let p5 : (yys = filter f (filter g xs)) = trans p1 p3 in
      let p6 : (filter f (filter g xs) = filter g xs) = filterImplication' {f, g} p0 xs (filter f (filter g xs)) Refl in
      let p7 : (yys = filter g xs) = replace {p = (yys ===)} p6 p5 in
      rewrite p2 in p7

public export
0 filterImplication : ((x : a) -> (g x = True) -> (f x = True)) -> (filter f (filter g l) = filter g l)
filterImplication p = filterImplication' {f, g} p l (filter f (filter g l)) Refl

0 filterExtensionality' : {f : a -> Bool} -> {g : a -> Bool} -> {p : (x : a) -> f x = g x} -> (l : List a) -> (filter f l = filter g l)
filterExtensionality' [] = Refl
filterExtensionality' (x :: xs) =
  let rec = filterExtensionality' {f, g, p} xs in
  case MkDPair (f x) Refl {p = (f x ===)} of
    MkDPair True p0 =>
      let p1 : (g x = True) = rewrite sym $ p x in p0 in
      rewrite p1 in
      rewrite p0 in
      rewrite rec in
      Refl
    MkDPair False p0 =>
      let p1 : (g x = False) = rewrite sym $ p x in p0 in
      rewrite p1 in
      rewrite p0 in
      rewrite rec in
      Refl

public export
0 filterExtensionality : ((x : a) -> f x = g x) -> (filter f l = filter g l)
filterExtensionality p = filterExtensionality' {p} l


module QAOA

import Data.Nat
import Data.Vect
import Graph
import Lemmas
import Unitary
import Control.Linear.LIO
import QStateT
import Injection
import LinearTypes
import Complex
import System.Random
import QuantumOp
import RandomUtilities

%default total

||| Vanilla QAOA : we use QAOA with a vanilla optimisation procedure to solve MAXCUT.

-------------------------QUANTUM CIRCUITS----------------------

||| The unitary operator induced by the mixing hamiltonian.
||| n    -- the arity of the operator
||| beta -- the rotation angle parameter
mixingUnitary : (n : Nat) -> (beta : Double) -> Unitary n
mixingUnitary n beta = tensorn n (RxGate beta)

||| Helper function for costUnitary
||| m              -- number of vertices of the input subgraph
||| n              -- number of remaining edges between current vertex and the rest
||| prf            -- proof witness that the number of vertices does not exceed the arity of the operator
||| gamma          -- the rotation parameter
||| edges          -- vector of edges that the current vertex is connected to
||| currentUnitary -- the currently constructed unitary operator
||| output         -- the final unitary operator
costUnitary' : {n : Nat} -> {m : Nat} -> {auto prf : n < m = True} ->
               (gamma : Double) -> (edges : Vect n Bool) -> (currentUnitary : Unitary m) -> Unitary m
costUnitary' _ [] currentUnitary = currentUnitary
costUnitary' {n = S k} gamma (False :: xs) currentUnitary =
  let proof1 = lemmaLTSuccLT k m
  in costUnitary' gamma xs currentUnitary
costUnitary' {n = S k} gamma (True  :: xs) currentUnitary =
  let proof1 = lemmaCompLT0 m (S k)
      proof2 = lemmaLTSuccLT k m
      cx     = CNOT 0 (S k) (IdGate {n = m})
      rzcx   = P gamma (S k) cx
      rest   = costUnitary' gamma xs currentUnitary
  in rest . cx . rzcx

||| The unitary operator induced by the cost hamiltonian.
||| n      -- the number of vertices of the input graph
||| graph  -- the input graph
||| gamma  -- rotation parameter
||| output -- the resulting unitary operator
costUnitary : {n : Nat} -> (graph: Graph n) -> (gamma : Double) -> Unitary n
costUnitary Empty _ = IdGate
costUnitary (AddVertex graph edges) gamma =
  let circuit = (IdGate {n = 1}) # (costUnitary graph gamma)
      proof1 = lemmaLTSucc n
  in costUnitary' gamma edges circuit

||| The iterated cost and mixing unitaries for QAOA_p
||| n       -- the number of vertices of the graph
||| p       -- the "p" parameter of QAOA_p, i.e., the number of iterations of the mixing and cost unitaries
||| betas   -- list of rotation parameters for the mixing hamiltonians
||| gammas  -- list of rotation parameters for the cost hamilitonians
||| graph   -- the input graph
||| output  -- the overall unitary operator of QAOA_p
QAOA_Unitary' : {n : Nat} ->
               (betas : Vect p Double) -> (gammas : Vect p Double) ->
               (graph: Graph n) ->
               Unitary n
QAOA_Unitary' [] [] g = IdGate
QAOA_Unitary' (beta :: betas) (gamma :: gammas) g =
  let circuit = QAOA_Unitary' betas gammas g
  in circuit . mixingUnitary n beta . costUnitary g gamma

||| The overall unitary operator for QAOA_p
||| n       -- the number of vertices of the graph
||| p       -- the "p" parameter of QAOA_p, i.e., the number of iterations of the mixing and cost unitaries
||| betas   -- list of rotation parameters for the mixing hamiltonians
||| gammas  -- list of rotation parameters for the cost hamilitonians
||| graph   -- the input graph
||| output  -- the overall unitary operator of QAOA_p
export
QAOA_Unitary : {n : Nat} ->
               (betas : Vect p Double) -> (gammas : Vect p Double) ->
               (graph: Graph n) ->
               Unitary n
QAOA_Unitary betas gammas graph = (QAOA_Unitary' betas gammas graph) . (tensorn n HGate)

-------------------------CLASSICAL PART------------------------

||| The (probabilistic) classical optimisation procedure for QAOA.
||| IO output allows us to use probabilistic optimisation procedures.
||| Given all previously observed information, determine new rotation angles for the next QAOA run.
||| Remark: we randomly generate the next rotation angles for simplicity.
|||
||| k             -- number of previous iterations of the algorithm
||| p             -- "p" parameter for QAOA_p
||| n             -- number of vertices of the input graph
||| graph         -- the input graph
||| previous_info -- previously used parameters and previously observed cuts from QAOA runs
||| IO output     -- new rotation angles for the next run of QAOA
classicalOptimisation : {p : Nat} ->
                       (graph : Graph n) ->
                       (previous_info : Vect k (Vect p Double, Vect p Double, Cut n)) ->
                       IO (Vect p Double, Vect p Double)
classicalOptimisation g ys = do
  betas <- randomVect p
  gammas <- randomVect p
  pure (betas,gammas)

-----------------------------QAOA------------------------------

||| Helper function for QAOA
|||
||| n      -- number of vertices of the input graph
||| p      -- the "p" parameter of QAOA_p
||| k      -- number of times we sample (the number of times we execute QAOA_p)
||| graph  -- input graph of the problem
||| output -- all observed cuts and all rotation angles from all the runs of QAOA
QAOA' : QuantumOp t =>
        {n : Nat} ->
        (k : Nat) -> (p : Nat) -> (graph : Graph n) ->
        IO (Vect k (Vect p Double, Vect p Double, Cut n))
QAOA' 0 p graph = pure []
QAOA' (S k) p graph = do
  previous_info <- QAOA' {t} k p graph
  (betas, gammas) <- classicalOptimisation graph previous_info
  let circuit = QAOA_Unitary betas gammas graph
  cut <- run (do
              qs <- newQubits {t} n
              qs <- applyUnitary qs circuit
              measureAll qs
              )
  pure $ (betas, gammas, cut) :: previous_info

||| QAOA for the MAXCUT problem. Given an input graph, return the best observed cut after some number of iterations.
|||
||| n      -- number of vertices of the input graph
||| p      -- the "p" parameter of QAOA_p
||| k      -- number of times we sample (the number of times we execute QAOA_p)
||| graph  -- input graph of the problem
||| output -- best observed cut from the execution of the algorithm
export
QAOA : QuantumOp t =>
       {n : Nat} ->
       (k : Nat) -> (p : Nat) -> Graph n ->
       IO (Cut n)
QAOA k p graph = do
  res <- QAOA' {t} k p graph
  let cuts = map (\(_, _, cut) => cut) res
  let (cut,size) = bestCut graph cuts
  pure cut


data ListLast : List a -> Type where
     Empty : ListLast []
     NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x])

listLast : (xs : List a) -> ListLast xs
listLast [] = Empty
listLast (x :: xs) = case listLast xs of
                          Empty => NonEmpty [] x
                          NonEmpty xs y => NonEmpty (x :: xs) y

describe_list_end : List Int -> String

describe_list_end input with (listLast input)
  describe_list_end [] | Empty = ?describe_list_end_rhs_1
  describe_list_end (xs ++ [x]) | (NonEmpty xs x) = ?describe_list_end_rhs_2


> module Fraction.Fraction

> import PNat.PNat

> %default total
> %access public export

> ||| Fraction representation
> Fraction : Type
> Fraction = (Nat, PNat)


module Struts

data Rat : Nat -> Nat -> Type where
  MkRat : (a : Nat) -> (b : Nat) -> Rat a b

multRat : Rat a b -> Rat c d -> Rat (a*c) (b*d)
multRat (MkRat a b) (MkRat c d) = MkRat (a*c) (b*d)

divRat : Rat a b -> Rat c d -> Rat (a*d) (b*c)
divRat (MkRat a b) (MkRat c d) = MkRat (a*d) (b*c)

addRat : Rat a b -> Rat c d -> Rat (a*d + b*c) (b*d)
addRat (MkRat a b) (MkRat c d) = MkRat (a*d + b*c) (b*d)

simplify : Rat a b -> Rat (divNat a (gcd a b)) (divNat b (gcd a b))
simplify (MkRat a b) = MkRat (divNat a (gcd a b)) (divNat b (gcd a b))

fromNat : (n : Nat) -> Rat n 1
fromNat n = MkRat n 1

data Pitch = A | B | C | D | E | F | G

data Note : (r : Rat a b) -> Type where
  MkNote : Pitch -> Note r

quarter : Pitch -> Note (MkRat 1 4)
quarter = MkNote

data NoteSequence : (r : Rat a b) -> Type where
  Empty : NoteSequence (fromNat 0)
  Append : Note s -> NoteSequence r -> NoteSequence (addRat s r)

data Measure : (r : Rat a b) -> Type where
  MkMeasure : NoteSequence r -> Measure r

fin : NoteSequence (fromNat 0)
fin = Empty

infixr 10 ~>

(~>) : Note s -> NoteSequence r -> NoteSequence (addRat s r)
(~>) = Append

beatMeasure : Measure (MkRat 1 4)
beatMeasure = MkMeasure (quarter C ~> fin)


%hint
mycong : (f : a -> b) -> x = y -> f x = f y
mycong f Refl = Refl

plusZ : (n : Nat) -> plus n Z = n

plusS : (n : Nat) -> (m : Nat) -> plus n (S m) = S (plus n m)


{- Ctrl-Alt-A: Add definition
   Ctrl-Alt-C: Case split
   Ctrl-Alt-D: Documentation
   Ctrl-Alt-L: Lift hole: Lifts a hole to the top level as a new function definition
   Ctrl-Alt-M: Match: Replaces a hole with a case expression that matches on an intermediate result
   Ctrl-Alt-R: Reloads and typechecks the current buffer
   Ctrl-Alt-S: Search
   Ctrl-Alt-T: Type-check: Displays the type under cursor -}
module Main

import Data.Vect

data Elem' : a -> Vect k a -> Type where
  Here' : Elem' x (x :: xs)
  There' : (later : Elem' x xs) -> Elem' x (y :: xs)

removeElemPrf :
  (value : a) ->
  (xs : Vect (S n) a) ->
  (prf : Elem value xs) ->
  Vect n a
removeElemPrf value (value :: ys) Here = ys
removeElemPrf {n = Z} value (y :: []) (There later) = absurd later
removeElemPrf {n = (S k)} value (y :: ys) (There later) = y :: removeElemPrf value ys later

removeElem :
  (value : a) ->
  (xs : Vect (S n) a) ->
  {auto prf : Elem value xs} ->
  Vect n a
removeElem x xs {prf} = removeElemPrf x xs prf

notInTail : (notHere : (value = x) -> Void) -> (notThere : Elem value xs -> Void) -> Elem value (x :: xs) -> Void
notInTail notHere notThere Here = notHere Refl
notInTail notHere notThere (There later) = notThere later

notInNil : Elem value [] -> Void
notInNil Here impossible
notInNil (There _) impossible

isYes : Dec a -> Bool
isYes (Yes prf) = True
isYes (No contra) = False

isElem' : DecEq ty => (value : ty) -> (xs : Vect n ty) -> Dec (Elem value xs)
isElem' value [] = No notInNil
isElem' value (x :: xs) = case decEq value x of
  Yes Refl   => Yes Here
  No notHere => case isElem' value xs of
    Yes prf => Yes (There prf)
    No notThere => No (notInTail notHere notThere)

data LElem : a -> List a -> Type where
  LHere : LElem a (a :: as)
  LThere : LElem a as -> LElem a (b :: as)

data Last : List a -> a -> Type where
  LOne : Last [value] value
  LCons : (prf : Last xs value) -> Last (x :: xs) value

noLast1 : (notLast : (x = value) -> Void) -> Last [x] value -> Void
noLast1 notLast LOne = notLast Refl
noLast1 _ (LCons LOne) impossible
noLast1 _ (LCons (LCons _)) impossible

noLast2 : (noLast : Last (y :: ys) value -> Void) -> Last (x :: (y :: ys)) value -> Void
noLast2 noLast (LCons prf) = noLast prf

noLast0 : Last [] value -> Void
noLast0 LOne impossible
noLast0 (LCons _) impossible

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No noLast0
isLast (x :: []) value = case decEq x value of
  Yes Refl => Yes LOne
  No notLast => No (noLast1 notLast)
isLast (x :: y :: ys) value = case isLast (y :: ys) value of
  Yes prf => Yes (LCons prf)
  No noLast => No (noLast2 noLast)

main : IO ()
main = do
  printLn $ removeElem 3 [1,2,3]
  printLn $ isYes $ isElem' 3 [1,2,3]
  printLn $ isYes $ isElem' 10 [1,2,3,4,5,6,7,8,9]
--  printLn $ isYes $ isLast 10 [1,2,3,4,5,6,7,8,9] -- Idris bug: Infinite loop


import public Lightyear
import public Lightyear.Char
import public Lightyear.Strings

Name : Type
Name = String

showParen : String -> String
showParen x = "(" ++ x ++ ")"

data Tm
  = Var Name           -- x
  | Lam Name Tm        -- \x. t
  | App Tm Tm          -- t u
  | Let Name Tm Tm     -- let x = t in u
Show Tm where
  show (Var str) = str
  show (Lam x t) = showParen ("λ" ++ x ++ "." ++ show t)
  show (App t u) = showParen ("" ++ show t ++ " " ++ show u)
  show (Let str tm1 tm2) = showParen ("Let " ++ str ++ " = " ++ show tm1 ++ " in " ++ show tm2)

-- parsing

keyword : String -> Bool
keyword x = x == "λ" || x == "in" || x == "let"

pIdent' : Parser Name
pIdent' = do f <- satisfy (isAlphaNum)
             i <- many (satisfy isAlphaNum)
             pure (pack (f :: i)) <* spaces

pIdent : Parser Name
pIdent = do
  str <- pIdent'
  guard (not (keyword str))
  pure str

pBind : Parser Name
pBind = pIdent <|> (token "_" *> pure "_")

mutual
  pAtom : Parser Tm
  pAtom = (Var <$> pIdent) <|> parens pTm -- what's `<$>` doing here?

  pTm : Parser Tm
  pTm = pLet <|>| pLam <|>| pSpine

  pLam : Parser Tm
  pLam = do
    char 'λ' <|> char '\\'
    xs <- some pBind
    token "."
    t <- pTm
    pure (foldr Lam t xs)

  pLet : Parser Tm
  pLet = do
    token "let"
    x <- pBind
    token "="
    t <- pTm
    token "in"
    u <- pTm
    pure $ Let x t u

  pSpine : Parser Tm
  pSpine = foldl1 App <$> some pAtom

-- evaluation

data Val
  = VVar Name
  | VApp Val Val
  | VLam Name (Val -> Val)

Env : Type
Env = List (Name, Maybe Val)

fresh : Env -> Name -> Name
fresh env "_" = "_"
fresh env x = case lookup x env of
                   Nothing => x
                   (Just _) => fresh env (x ++ "'")

eval : Env -> Tm -> Val
eval env (Var x) = let findX = lookup x env in
                       (case findX of
                             Nothing => VVar x
                             (Just x') => (case x' of
                                                Nothing => VVar x
                                                (Just x'') => x''))
eval env (App t u) = let evalT = eval env t
                         evalU = eval env u
                         in
                         (case evalT of
                               (VLam _ f) => f evalU
                               _ => VApp evalT evalU)
eval env (Lam x t) = VLam x (\u => eval ((x, Just u)::env) t)
eval env (Let x t u) = let nextEnv = Just (eval env t) in
                           eval ((x, nextEnv)::env) u

quote : Env -> Val -> Tm
quote env (VVar x) = Var x
quote env (VApp t u) = App (quote env t) (quote env u)
quote env (VLam x t) = let freshX = fresh env x in
                           Lam freshX (quote ((x, Nothing)::env) (t (VVar x)))
nf : Env -> Tm -> Tm
nf env = let qe = quote env
             ee = eval env in
             qe . ee

test : Maybe Tm
test = let parsed = (Lightyear.Strings.parse (pTm) "let five = \\s z. s (s (s (s (s z)))) in let add = \\a b s z. a s (b s z) in let mul = \\a b s z. a (b s) z in let ten = add five five in let hundred = mul ten ten in let thousand = mul ten hundred in let tenthousand = mul ten thousand in tenthousand") in
           (case parsed of
                 (Left l) => Nothing
                 (Right r) => Just (nf [] r))

test2 : Maybe Tm
test2 = let parsed = (Lightyear.Strings.parse (pTm) "let true = (\\x y. x) in let false = (\\x y. y) in let and = (\\x y. (x (y true false) false)) in let or = (\\x y. (x true (y true false))) in or false true") in
           (case parsed of
                 (Left l) => Nothing
                 (Right r) => Just (nf [] r))


module Types.Inclusion

import Syntax.PreorderReasoning
import Control.Isomorphism

%default total

-- An inclusion from a to b
data Inclusion : (a, b : Type) -> Type where
  Include : (upcast : a -> b) ->
            (downcast : b -> Maybe a) ->
            (upThenDown : (x : a) -> downcast (upcast x) = Just x) ->
            (downThenUp : (y : b) -> maybe () (\x => upcast x = y) (downcast y)) ->
            Inclusion a b

includeRefl : Inclusion a a
includeRefl = Include id Just (\x => Refl) (\y => Refl)

includeTrans : Inclusion a b -> Inclusion b c -> Inclusion a c
includeTrans {a} {b} {c} (Include u d ud du) (Include u' d' ud' du') =
  Include (\x => u' (u x))
          (\y => (d' y) >>= d)
          ok1
          ok2

    where ok1 : (x : a) -> (d' (u' (u x))) >>= d = Just x
          ok1 x = ((d' (u' (u x))) >>= d) ={ cong {f=(>>= d)} (ud' (u x)) }=
                  ((Just (u x)) >>= d)    ={ Refl }=
                  (d (u x))               ={ ud x }=
                  (Just x)                QED

          ok2 : (y : c) -> maybe () (\x => u' (u x) = y) ((d' y) >>= d)
          ok2 y = ok2' (d' y) (du' y) -- Do the first case analysis, but keep the proof
            where ok2' : (z : Maybe b) ->
                         maybe () (\x => u' x = y) z ->
                         maybe () (\x => u' (u x) = y) (z >>= d)
                  ok2' Nothing prf = ()
                  ok2' (Just x) prf = ok2'' (d x) (du x) -- second analysis, keep proof
                    where ok2'' : (z : Maybe a) ->
                                  maybe () (\w => u w = x) z ->
                                  maybe (the Type ()) (\x1 => u' (u x1) = y) z
                          ok2'' Nothing prf2 = ()
                          ok2'' (Just v) prf2 = (u' (u v)) ={ cong prf2 }=
                                                (u' x)     ={ prf       }=
                                                y          QED

-- Enable preorder reasoning syntax over inclusions
qed : (a : Type) -> Inclusion a a
qed a = includeRefl

step : (a : Type) -> Inclusion a b -> Inclusion b c -> Inclusion a c
step a incl1 incl2 = includeTrans incl1 incl2

-- Every isomorphism gives an inclusion mapping
includeIso : Iso a b -> Inclusion a b
includeIso {a} {b} (MkIso to from toFrom fromTo) =
  Include to (\x => Just (from x)) ok1 ok2
    where ok1 : (x : a) -> (Just (from (to x)) = Just x)
          ok1 x = rewrite fromTo x in Refl -- workaround for de Bruijn index bug
          ok2 : (y : b) -> to (from y) = y
          ok2 y = rewrite toFrom y in Refl -- workaround for de Bruijn index bug

castUp : Inclusion a b -> a -> b
castUp (Include up _ _ _) = up

castDown : Inclusion a b -> b -> Maybe a
castDown (Include _ down _ _) = down


import Data.List

data SnocList : List a -> Type where
     Empty : SnocList []
     Snoc : (x, xs : _) -> (rec : SnocList xs) -> SnocList (xs ++ [x])

snocListHelp : {input : _} ->
               (snoc : SnocList input) -> (rest : List a) -> SnocList (input ++ rest)
snocListHelp snoc [] = rewrite appendNilRightNeutral input in snoc
snocListHelp snoc (x :: xs)
    = rewrite appendAssociative input [x] xs in
              snocListHelp (Snoc x input snoc) xs

snocList : (xs : List a) -> SnocList xs
snocList xs = snocListHelp Empty xs

my_reverse_help : (input : List a) -> SnocList input -> List a
my_reverse_help [] Empty = []
my_reverse_help (xs ++ [x]) (Snoc x xs rec) = x :: my_reverse_help xs rec

my_reverse1 : List a -> List a
my_reverse1 input = my_reverse_help input (snocList input)

my_reverse : List a -> List a
my_reverse input with (snocList input)
  my_reverse [] | Empty = []
  my_reverse (xs ++ [x]) | (Snoc x xs rec) = x :: my_reverse xs | rec


module Common.Abbrev

%default total
%access public export

Binop : Type -> Type
Binop s = s -> s -> s

Binrel : Type -> Type
Binrel s = s -> s -> Type

OuterBinop : {index : Type} -> (f : index -> Type) -> (a,b,c : index) -> Type
OuterBinop f a b c = f a -> f b -> f c

infixl 5 ===
infixl 5 @==

||| associative infix syntax for `trans`
(===) : a = b -> b = c -> a = c
(===) Refl Refl = Refl

(@==) : a = b -> a = c -> b = c
(@==) Refl Refl = Refl


> module Math
> import Data.Vect
> import Data.HVect
> import Data.List
> import Data.Fin

We take some tricks from https://boxbase.org/entries/2019/sep/16/grabbag-of-idris-tricks/ and http://firsov.ee/finset/finset.pdf.

Use Pauli group as small example:

> data PauliGroup : Type where
>   X : PauliGroup
>   Y : PauliGroup
>   Zp : PauliGroup
>   I : PauliGroup

We provide a complete list of PauliGroup elements:

> listPauli : List PauliGroup
> listPauli = [X,Y,Zp,I]

> allPauli : (x: PauliGroup) -> Data.List.Elem x Math.listPauli
> allPauli X = Here
> allPauli Y = There Here
> allPauli Zp = There (There Here)
> allPauli I = There (There (There Here))

> xIsNotY : (X = Y) -> Void
> xIsNotY Refl impossible
> xIsNotZ : (X = Zp) -> Void
> xIsNotZ Refl impossible
> xIsNotI : (X = I) -> Void
> xIsNotI Refl impossible
> yIsNotZ : (Y = Zp) -> Void
> yIsNotZ Refl impossible
> yIsNotI : (Y = I) -> Void
> yIsNotI Refl impossible
> zIsNotI : (Zp = I) -> Void
> zIsNotI Refl impossible

> DecEq PauliGroup where
>   decEq X X = Yes Refl
>   decEq X Y = No xIsNotY
>   decEq X Zp = No xIsNotZ
>   decEq X I = No xIsNotI
>   decEq Y X = No (\c => xIsNotY (sym c))
>   decEq Y Y = Yes Refl
>   decEq Y Zp = No yIsNotZ
>   decEq Y I = No yIsNotI
>   decEq Zp X = No (\c => xIsNotZ (sym c))
>   decEq Zp Y = No (\c => yIsNotZ (sym c))
>   decEq Zp Zp = Yes Refl
>   decEq Zp I = No zIsNotI
>   decEq I X = No (\c => xIsNotI (sym c))
>   decEq I Y = No (\c => yIsNotI (sym c))
>   decEq I Zp = No (\c => zIsNotI (sym c))
>   decEq I I = Yes Refl

And we give the group structure:

> multPauli : PauliGroup -> PauliGroup -> PauliGroup
> multPauli X X = I
> multPauli X Y = Zp
> multPauli X Zp = Y
> multPauli X I = X
> multPauli Y X = Zp
> multPauli Y Y = I
> multPauli Y Zp = X
> multPauli Y I = Y
> multPauli Zp X = Y
> multPauli Zp Y = X
> multPauli Zp Zp = I
> multPauli Zp I = Zp
> multPauli I X = X
> multPauli I Y = Y
> multPauli I Zp = Zp
> multPauli I I = I

> commPauli : (x:PauliGroup) -> (y:PauliGroup) -> (multPauli x y = multPauli y x)
> commPauli X X = Refl
> commPauli X Y = Refl
> commPauli X Zp = Refl
> commPauli X I = Refl
> commPauli Y X = Refl
> commPauli Y Y = Refl
> commPauli Y Zp = Refl
> commPauli Y I = Refl
> commPauli Zp X = Refl
> commPauli Zp Y = Refl
> commPauli Zp Zp = Refl
> commPauli Zp I = Refl
> commPauli I X = Refl
> commPauli I Y = Refl
> commPauli I Zp = Refl
> commPauli I I = Refl

Obviously there are a number of shortcomings with this approach.... and associativity
would take 64 lines to prove...

> Injective : {t,u:Type} -> (t -> u) -> Type
> Injective f {t} = (x,y:t) -> (f x = f y) -> (x = y)

> Surjective : {t,u:Type} -> (t -> u) -> Type
> Surjective f {t} {u} = (y:u) -> (x:t ** f x = y)

> getInverse : {t,u:Type} -> {func: t -> u} -> (Injective func) -> (Surjective func) -> (u -> t)
> getInverse {t} {u} {func} inj surj = \y => fst (surj y)

> Bijective : {t,u : Type} -> (t -> u) -> Type
> Bijective f {t} {u} = ?bij

Proofs that a list contain all possible elements of a type:

> All : {t : Type} -> List t -> Type
> All xs {t} = (x:t) -> Elem x xs

Given a type t and a proof of t, it is a contradiction to have a proof that the
empty list contains all elements of t.

> allNotEmpty : All {t} [] -> t -> Void
> allNotEmpty f x = absurd (f x)

> voidEmptyAll : Uninhabited t => All {t} []
> voidEmptyAll = \c => absurd c

Decidable list membership:

> DecIn : (t: Type) -> Type
> DecIn t = (x:t) -> (xs : List t) -> Dec (Elem x xs)

Decidable equality and decidable list membership are equivalent:

> decInToDeqEq : DecIn t -> (x:t) -> (y:t) -> Dec (x = y)
> decInToDeqEq f x y = case (f x [y]) of
>   Yes Here => Yes Refl
>   No contra => No (\eq => contra (rewrite eq in Here))

Little helper lemmas:

> matchingSingleton : Data.List.Elem x [y] -> (x = y)
> matchingSingleton Here = Refl
> matchingSingleton (There later) impossible

> deqEqToDeqIn : DecEq t => DecIn t
> deqEqToDeqIn x [] = No absurd
> deqEqToDeqIn x (y::ys) with (deqEqToDeqIn x ys)
>   deqEqToDeqIn x (y::ys) | No notLater = case decEq x y of
>       Yes Refl => Yes Here
>       No contra => No (\later =>
>                           case later of
>                               Here => contra (matchingSingleton Here)
>                               (There t) => notLater t)
>   deqEqToDeqIn x (y::ys) | Yes later = Yes (There later)

Proof that a given type is a "mere proposition" (i.e. it only has one element)

> Prop : (t:Type) -> Type
> Prop t = (p1:t) -> (p2:t) -> (p1=p2)

We also have a notion of a List with no duplicates:

> NoDupes : {t:Type} -> List t -> Type
> NoDupes {t} xs = (x:t) -> Prop (Elem x xs)

Some trivial helper lemmas:

> noDupesInHeadLemma : Elem x xs -> NoDupes (x :: xs) -> Void
> noDupesInHeadLemma {x = x} {xs = []} _ _ impossible
> noDupesInHeadLemma {x} a b = hereIsNotThere (b x Here (There a))

If a type has decidable equality, then All and NoDupes are decidable.
We need a (somewhat metamathematical) lemma to start stating that any two
void values of the same type are equal (there are in fact zero of them - this
is just a wrapper for "void can prove anything")

> voidsAreEquivalent : {t: Type} -> (t -> Void) -> (a:t) -> (b:t) -> (a=b)
> voidsAreEquivalent f a b = void (f a)

> sameTheresLemma : {a: Data.List.Elem x xs} -> (There a = There a)
> sameTheresLemma = Refl

To avoid an awkward workaround with Void types, we force the caller to prove that
the type isn't void by providing some item. This might need some work...

> deqEqToAllIncomplete : DecEq t => (xs:List t) -> t -> Dec (All xs)
> deqEqToAllIncomplete [] someItem = No (\c => allNotEmpty c someItem)
> deqEqToAllIncomplete (x :: xs) someitem = Yes (\c =>
>   case (decEq x c) of
>       Yes pf => rewrite pf in Here
>       No contra => ?newh2)

After some reflection, I don't think this will work. We need to know *ahead of time*
that All {t} [xs] exists. This method will always fail to converge for Nats.

> thereLemma1 : {a: Data.List.Elem x xs} -> {b : Data.List.Elem x xs} -> (a = b) -> There a = There b
> thereLemma1 {a = Here} {b = Here} Refl = Refl
> thereLemma1 {a = Here} {b = (There _)} Refl impossible
> thereLemma1 {a = (There _)} {b = Here} Refl impossible
> thereLemma1 {a = (There x)} {b = (There x)} Refl = Refl

> thereLemma2 : {a: Data.List.Elem x xs} -> {b : Data.List.Elem x xs} -> (There a = There b) -> a = b
> thereLemma2 {a = Here} {b = Here} pf = Refl
> thereLemma2 {a = Here} {b = (There _)} Refl impossible
> thereLemma2 {a = (There _)} {b = Here} Refl impossible
> thereLemma2 {a = (There x)} {b = (There x)} Refl = Refl

> consNoDupes : DecEq t => {x : t} -> NoDupes {t} xs -> (Not (Elem x xs)) -> NoDupes (x :: xs)
> consNoDupes {x = x} noDupesSublist notIn y pf1 pf2 with (decEq x y)
>   consNoDupes {x = y} noDupesSublist notIn y Here Here | Yes pf = Refl
>   consNoDupes {x = y} noDupesSublist notIn y Here (There later) | Yes pf = absurd (notIn later)
>   consNoDupes {x = y} noDupesSublist notIn y (There later) Here | Yes pf = absurd (notIn later)
>   consNoDupes {x = x} noDupesSublist notIn y (There later) (There z) | Yes pf = absurd (notIn (rewrite pf in later)) --rewrite (noDupesSublist y later z) in Refl
>   consNoDupes {x = y} noDupesSublist notIn y Here Here | No contra = Refl
>   consNoDupes {x = y} noDupesSublist notIn y Here (There later) | No contra = absurd (notIn later)
>   consNoDupes {x = y} noDupesSublist notIn y (There later) Here | No contra = absurd (notIn later)
>   consNoDupes {x = x} noDupesSublist notIn y (There later) (There z) | No contra = let ndupes = (noDupesSublist y later z) in thereLemma1 ndupes

> dupeCons : NoDupes (x :: xs) -> NoDupes xs
> dupeCons dupeBiglist item pf1 pf2 = thereLemma2 (dupeBiglist item (There pf1) (There pf2))

> deqEqToDupe : DecEq t => (xs:List t) -> Dec (NoDupes xs)
> deqEqToDupe [] = Yes (\a => (\b => (\c => (voidsAreEquivalent uninhabited b c))))
> deqEqToDupe (x :: xs) with (isElem x xs)
>   deqEqToDupe (x :: xs) | Yes pf = No (noDupesInHeadLemma pf)
>   deqEqToDupe (x :: xs) | No contra = case deqEqToDupe xs of
>       Yes noDupes => Yes (consNoDupes noDupes contra)
>       No areDupes => No (\c => areDupes (dupeCons c))

If P is a decidable proposition, we can quotient P by the total equivalence relation
and get a "squashed" type {what is this relation?}

> squash : {p:Type} -> Dec p -> Type
> squash (Yes _) = Unit
> squash (No _) = Void

An example: Elem x [x,y,x] is decidable:

> exSquash1 : Dec (Data.List.Elem X [X,Y,X])
> exSquash1 = Yes Here

> exSquash2 : Dec (Data.List.Elem X [X,Y,X])
> exSquash2 = Yes (There (There Here))

Both "squash" to Unit. Note that any two squashed values are trivially equal:

> propSquash : {p: Type} -> (d : Dec p) -> Prop (squash d)
> propSquash (Yes prf) () () = Refl
> propSquash (No contra) v1 _ = absurd v1

> fromSquash : {p:Type} -> (d : Dec p) -> squash d -> p
> fromSquash (Yes prf) () = prf

makeAllFin : (k:Nat) -> (xs:(List (Fin (S k))) ** All (Fin (S k)) xs)
makeAllFin Z = ([FZ] ** (IsAll (\x => Here)))

Kuratowski finiteness:

> Listable : (t : Type) -> Type
> Listable t = (xs ** (All {t} xs))

An alternative idea is to require a surjection Fin n to t for some Nat n:

> FinSurjective : (t: Type) -> Type
> FinSurjective ty = (n:Nat ** (fromFin : (Fin n -> ty) ** (Surjective fromFin)))

These notions are equivalent. We need some helper lemmas... it is quite likely
that these can be cleaned up considerably...

> getIndexOfElem : Data.List.Elem x xs -> Fin (length xs)
> getIndexOfElem Here = FZ
> getIndexOfElem (There later) = FS (getIndexOfElem later)

> getIndexFromAll : All {t} xs -> t -> Fin (length xs)
> getIndexFromAll {xs = []} pf x = absurd (pf x)
> getIndexFromAll {xs = (y :: xs)} pf x = getIndexOfElem (pf x)

> finIndexList : (l:List t) -> Fin (length l) -> t
> finIndexList [] _ impossible
> finIndexList (x :: _) FZ = x
> finIndexList (_ :: xs) (FS y) = finIndexList xs y

> getIndexOfElemLemma : (pf : Data.List.Elem x xs) -> finIndexList xs (getIndexOfElem pf) = x
> getIndexOfElemLemma {xs = (x :: ys)} Here = Refl
> getIndexOfElemLemma {xs = (y :: ys)} (There later) = getIndexOfElemLemma later

> getIndexOfAllLemma : (pf : All {t} xs) -> (x : t) -> finIndexList xs (getIndexFromAll pf x) = x
> getIndexOfAllLemma {xs} pf x with (pf x)
>   getIndexOfAllLemma {xs= x :: ys} pf x | Here = getIndexOfElemLemma (pf x)
>   getIndexOfAllLemma {xs= y :: ys} pf x | (There later) = getIndexOfElemLemma (pf x)

> finIndexListSurjectiveIfAll : All {t} xs -> Surjective (finIndexList xs)
> finIndexListSurjectiveIfAll {xs} pf = \y => ((getIndexFromAll pf y) ** (getIndexOfAllLemma pf y))

> indexIntoAll : All {t} xs -> (f : (Fin (length xs) -> t) ** Surjective f)
> indexIntoAll {xs} pf = ((finIndexList xs) ** (finIndexListSurjectiveIfAll pf))

> natToListFin : (n : Nat) -> List (Fin n)
> natToListFin Z = []
> natToListFin (S n) = (the (Fin (S n)) last) :: (map weaken (natToListFin n))

> lastFinLemma : {n: Nat} -> (((FS k) = last {n=n}) -> Void) -> ((k = last {n=n}) -> Void)
> lastFinLemma {n = Z} {k=_} _ impossible
> lastFinLemma {n = (S Z)} {k = FZ} contra = absurd (contra Refl)
> lastFinLemma {n = (S (S k))} {k = FZ} contra = ?lastFinLemma_rhs_4
> lastFinLemma {n = (S j)} {k = (FS x)} contra = ?lastFinLemma_rhs_3

 lastFinLemma {n = Z} {k = FZ} _ impossible
 lastFinLemma {n = Z} {k = (FS _)} _ impossible

> safeStrengthen : (f : Fin (S n)) -> (contra : (f = last {n=n}) -> Void) -> Fin n
> safeStrengthen {n=Z} FZ contra = absurd (contra Refl)
> safeStrengthen {n=(S k)} FZ contra = FZ
> safeStrengthen {n=(S k)} (FS x) contra = ?ssh_2

> natToListFinIsAll : (n : Nat) -> (All (natToListFin n))
> natToListFinIsAll Z = voidEmptyAll
> natToListFinIsAll (S n) = \f =>
>   case (decEq (the (Fin (S n)) last) f) of
>       Yes pf => rewrite pf in Here
>       No _ => ?newhole -- There (natToListFinIsAll n (safeStrengthen f))

natToListFinIsAll (S Z) = (\FZ => Here)

> getAllFins : (n : Nat) -> (xs : (List (Fin n)) ** All xs)
> getAllFins n = ((natToListFin n) ** (natToListFinIsAll n))

 getAllFins (S k) = ((getAllFinsInner (S k)) ** )

> listableIsFinSurjective : Listable t -> FinSurjective t
> listableIsFinSurjective (xs ** pf) = ((length xs) ** (indexIntoAll pf))

> finSurjectiveToList : FinSurjective t -> List t
> finSurjectiveToList (bd ** (surj ** pf)) = map surj (fst (getAllFins bd))

> finSurjectiveIsListable : FinSurjective t -> Listable t
> finSurjectiveIsListable (bound ** (surj ** pf)) = ?finSurjectiveIsListable_rhs_2

> contrapositive : (a -> b) -> Not b -> Not a
> contrapositive f nb a = nb (f a)

makeAllFin (S k) = ?makeAllFin_rhs_2

> interface Countable t where
>   FromNat : Nat -> t
>   ToNat : t -> Nat

> Countable Nat where
>   FromNat = id
>   ToNat = id

An $n$-place relation on a collection of sets $S_1, S_2,\dots,S_n$ is a set $R\subset
S_1 \times S_2 \times \dots \times S_n$. We say $s_1\in S_1,s_2\in S_2,\dots, s_n\in S_n$
are related by $R$ if $(s_1,s_2,\dots,s_n)\in R$.

> NaryRelation : Vect n Type -> Type
> NaryRelation xs = List (HVect xs) -- for our purposes it is fine to use lists instead of sets

> BinaryRelation : Vect 2 Type -> Type
> BinaryRelation = NaryRelation

> domain : BinaryRelation [xt,yt] -> List yt
> domain [] = []
> domain ([x,y] :: xs) = y :: (domain xs)

> codomain : BinaryRelation [xt,yt] -> List xt
> codomain [] = []
> codomain ([x,y] :: xs) = x :: (codomain xs)

> data PartialFunction : BinaryRelation [xy,yt] -> Type where
>


module Main

import Data.Vect

%default total

data PowerSource = Petrol | Pedal

data Vehicle : PowerSource -> Type where
     Bicycle : Vehicle Pedal
     Car : (fuel : Nat) -> Vehicle Petrol
     Bus : (fuel : Nat) -> Vehicle Petrol

wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels (Car _) = 4
wheels (Bus _) = 4

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus _) = Bus 200

append : Vect n elem -> Vect m elem -> Vect (n + m) elem
append [] ys = ys
append (x :: xs) ys = x :: append xs ys

zip' : Vect n a -> Vect n b -> Vect n (a , b)
zip' [] [] = []
zip' (x :: xs) (y :: ys) = (x, y) :: zip' xs ys

tryIndex : Integer -> Vect n a -> Maybe a
tryIndex {n} x l = case integerToFin x n of
                   Nothing => Nothing
                   Just f => Just (index f l)

vectTake : (m : Fin n) -> Vect n a -> Vect (finToNat m) a
vectTake FZ (x :: xs) = []
vectTake (FS y) (x :: xs) = x :: vectTake y xs

sumEntries : Num a => (m : Fin n) -> Vect n a -> Vect n a -> a
sumEntries FZ (x :: xs) (y :: ys) = (x + y)
sumEntries (FS x) (y :: xs) (z :: ys) = (sumEntries x xs ys)

sumEntries' : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries' {n} pos l1 l2 = case integerToFin pos n of
                            Nothing => Nothing
                            Just f => Just ((index f l1) + (index f l2))

main : IO ()
main = putStrLn (cast 'x')


import Data.Vect as V
import Data.Vect.Extra
import Data.Nat
import Data.List as L
import Data.String.Parser

import System.File

data Cucumber = H | V

isH : Maybe Cucumber -> Bool
isH (Just H) = True
isH _ = False

isV : Maybe Cucumber -> Bool
isV (Just V) = True
isV _ = False

Grid : Nat -> Nat -> Type
Grid x y = Vect (S y) (Vect (S x) (Maybe Cucumber))

cucumberParser : Parser (Maybe Cucumber)
cucumberParser = char '>' $> Just H <|> char 'v' $> Just V <|> char '.' $> Nothing

parser : Parser (x ** y ** Grid x y)
parser = do row <- some cucumberParser <* char '\n'
            let x = length row
            Just v <- pure $ toVect x row
              | Nothing => fail "not length"
            Yes ItIsSucc <- pure $ isItSucc x
              | No _ => fail "Row is zero"
            cs <- some ((ntimes x cucumberParser) <* char '\n')
            let y = length cs
            Just cs <- pure $ toVect y cs
              | Nothing => fail "not column"
            pure $ (_ ** (_ ** v :: cs))

Move : Nat -> Nat -> Type
Move x y = ((Fin (S x), Fin (S y)), (Fin (S x), Fin (S y)))

addWrap : {n : Nat} -> Fin (S n) -> Fin (S n)
addWrap f = case strengthen $ shift 1 f of
               Nothing => 0
               (Just f) => f

hMoves : {x : Nat} -> {y : Nat} -> Grid x y -> List (Move x y)
hMoves g = filter (\(_,(x,y)) => isNothing $ index x $ index y g) $ map (\(x,y,_) => ((x, y), (addWrap x, y))) $ toList $ join $ toList $ (\(y,xs) => filter (isH . snd . snd) $ toList $ mapWithPos (,y,) $ xs) <$> mapWithPos (,) g

vMoves : {x : Nat} -> {y : Nat} -> Grid x y -> List (Move x y)
vMoves g = filter (\(_,(x,y)) => isNothing $ index x $ index y g) $ map (\(x,y,_) => ((x, y), (x, addWrap y))) $ toList $ join $ toList $ (\(y,xs) => filter (isV . snd . snd) $ toList $ mapWithPos (,y,) $ xs) <$> mapWithPos (,) g

steps : {x : Nat} -> {y : Nat} -> Grid x y -> Nat
steps g = steps' 1 g
  where
    doMoves : Grid x y -> List (Move x y) -> Grid x y
    doMoves g [] = g
    doMoves g (((x1, y1), (x2, y2)) :: ms) = let c = index x1 $ index y1 g
                                                 g1 = updateAt y1 (replaceAt x1 Nothing) g
                                                 g2 = updateAt y2 (replaceAt x2 c) g1 in
                                                 doMoves g2 ms

    steps' : Nat -> Grid x y -> Nat
    steps' n g = case hMoves g of
                      [] => case vMoves g of
                                 [] => n
                                 ms => steps' (S n) (doMoves g ms)
                      ms => let g' = doMoves g ms in
                                case vMoves g' of
                                     [] => steps' (S n) g'
                                     ms => steps' (S n) (doMoves g' ms)

part1 : {n : Nat} -> {m : Nat} -> Grid n m -> IO String
part1 a = pure $ show $ steps a

main : IO ()
main = do Right input <- readFile "input.txt"
            | Left err => printLn err
          Right (MkDPair n (MkDPair m a), _) <- pure $ parse parser input
            | Left err => printLn err
          part1 a >>= putStrLn


AdderType : (numargs : Nat) -> Type -> Type
AdderType Z numType = numType
AdderType (S k) numType = (next : numType) -> AdderType k numType

adder : Num numType => (numargs : Nat) -> numType -> AdderType numargs numType
adder Z acc = acc
adder (S k) acc = \next => adder k (next + acc)


module Linear.Backprop

import Backprop
import Control.Optics
import Linear.V
import Linear.Math
import Linear.Optics

export
{n : _} -> CanBack a => CanBack (V n a) where
  zero = pure zero
  one = pure one
  add [] [] = []
  add (x :: xs) (y :: ys) = add x y :: add xs ys

export
(::) : {a, n : _} -> CanBack a => Node s a -> Node s (V n a) -> Node s (V (S n) a)
(::) = op2 $ \[x, xs] => (x :: xs, \(d :: ds) => [d, ds])

export
{n : _} -> NodeTraversable (V n) where
  sequence x = map (\i => x ^. at i) Fin.range

export
{n : _} -> NodeDistributive (V n) where
  collect [] = const []
  collect (node :: nodes) = node :: collect nodes

export
konst : {a, n : _} -> Num a => CanBack a => Node i a -> Node i (V n a)
konst = op1 $ \[x] => (pure x, \d => [sum d])

export
dot : {a : _} -> (Num a, CanBack a, Foldable f, Zippable f, NodeFunctor f)
  => Node i (f a) -> Node i (f a) -> Node i a
dot x y = V.dot (Node.sequence x) (Node.sequence y)

infixl 7 <.>
export
(<.>) : {a, n : _} -> Num a => CanBack a => Node i (V n a) -> Node i (V n a) -> Node i a
(<.>) = op2 $ \[x, y] => (x `dot` y, \d => let d' = pure d in [d' * y, x * d'])

export
outer : {n, m, a : _} -> (Num a, CanBack a) => Node i (T [n] a) -> Node i (T [m] a) -> Node i (T [n, m] a)
outer = op2 $ \[x, y] => (x `outer` y, \d => [d !* y, transpose d !* x])

export
(#>) : {m, n, a : _} -> Num a => CanBack a => Node i (T [m, n] a) -> Node i (T [n] a) -> Node i (T [m] a)
(#>) = op2 $ \[x, y] => (x !* y, \d => [d `outer` y, transpose x !* d])

-- export
-- (<#) : {m, n, a : _} -> Num a => CanBack a => Node i (T [m] a) -> Node i (T [m, n] a) -> Node i (T [n] a)

export
(*^) : {a : _} -> CanBack a => Num a => NodeFunctor f => Node i a -> Node i (f a) -> Node i (f a)
(*^) a = Node.map (a *)

export
(^*) : {a : _} -> CanBack a => NodeFunctor f => Num a => Node i (f a) -> Node i a -> Node i (f a)
x ^* y = y *^ x

-- export
-- (*!) : {a, f : _} -> (CanBack a, Num a, CanBack (f a), NodeTraversable t, NodeTraversable f, Functor t)
--   => Node i (t a) -> Node i (t (f a)) -> Node i (f a)

infixr 7 <>
export
(<>) : {n, p, m, a : _} -> (Num a, CanBack a) => Node i (T [m, n] a) -> Node i (T [n, p] a) -> Node i (T [m, p] a)
(<>) = op2 $ \[x, y] => (x !*! y, \d => [d !*! transpose y, transpose x !*! d])

export
asum : {a, n : _} -> Num a => CanBack a => Node i (V n a) -> Node i a
asum = op1 $ \[x] => (sum x, \d => [pure d])


data Vect : Nat -> Type -> Type where
     Nil : Vect Z a
     (::) : a -> Vect k a -> Vect (S k) a

%name Vect xs, ys, zs

my_cong : forall f . (x : a) -> (y : a) -> x = y -> f x = f y

my_curry : ((a, b) -> c) -> a -> b -> c

my_uncurry : (a -> b -> c) -> (a, b) -> c

append : Vect n a -> Vect m a -> Vect (n + m) a

lappend : (1 xs : List a) -> (1 ys : List a) -> List a

zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

data Env : Vect n Type -> Type where
     ENil : Env []
     ECons : a -> Env xs -> Env (a :: xs)

%name Env es

data Elem : a -> Vect n a -> Type where
     Here : Elem x (x :: xs)
     There : (p : Elem x xs) -> Elem x (y :: xs)

lookup : Elem ty vs -> Env vs -> ty

data Tree : (a : Type) -> Type where
  Leaf : a -> Tree a
  Node : a -> Tree a -> Tree a -> Tree a

foo : Tree Nat


module chap06_printf

-- intermediate type
data Format = Number Format     -- %d
            | Str Format        -- %s
            | Lit String Format
            | End

PrintfType : Format -> Type
PrintfType (Number f) = (i : Int) -> PrintfType f
PrintfType (Str f) = (str : String) -> PrintfType f
PrintfType (Lit s f) = PrintfType f
PrintfType End = String

-- helper function
printfFmt : (f : Format) -> (acc : String) -> PrintfType f
printfFmt (Number f) acc = \i => printfFmt f (acc ++ show i)
printfFmt (Str f) acc = \str => printfFmt f (acc ++ str)
printfFmt (Lit s f) acc = printfFmt f (acc ++ s)
printfFmt End acc = acc

toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: chars)        = Lit "%" (toFormat chars)
toFormat (c :: chars)          = case toFormat chars of
                                      Lit lit chars' => Lit (strCons c lit) chars'
                                      fmt => Lit (strCons c "") fmt

printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""

-- *chap06_printf> :t printf
-- printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
-- *chap06_printf> printf "hey, %s"
-- \str => prim__concat "hey, " str : String -> String
-- *chap06_printf> printf "hey, %s" "you"
-- "hey, you" : String


module Toolkit.Data.DList.Elem

import Toolkit.Data.DList

import public Toolkit.Decidable.Equality.Indexed

%default total

||| Proof that some element is found in a `DList`.
|||
||| @iTy     The type of the element's index.
||| @elemTy  The type of the list element.
||| @x       An element in the list.
||| @xs      The list itself.
||| @prf     Proof that the element's index is in the list in the same position as the element itself.
public export
data Elem : (iTy    : Type)
         -> (elemTy : iTy -> Type)
         -> forall i, is
          . (x      : elemTy i)
         -> (xs     : DList iTy elemTy is)
         -> Type
    where
      ||| Proof that the element is at the front of the list.
      H : (Equals ity elemTy x y) -> Elem ity elemTy x (y :: xs)

      ||| Proof that the element is found later in the list.
      T : (later : Elem iTy elemTy x       xs)
                -> Elem iTy elemTy x (x' ::xs)

listEmpty : Elem type e thing Nil -> Void
listEmpty (H x) impossible
listEmpty (T later) impossible

notInLater : (contraE : Equals type e x y -> Void)
          -> (contraR : Elem type e x xs -> Void)
          -> (prf    : Elem type e x (y::xs))
                    -> Void
notInLater contraE contraR (H z) = contraE z
notInLater contraE contraR (T later) = contraR later

export
isElem : {type : Type}
      -> {e    : type -> Type}
      -> DecEq type
      => DecEqIdx type e
      => {a      : type}
      -> {as     : List type}
      -> (thing  : e a)
      -> (things : DList type e as)
                -> Dec (Elem type e thing things)
isElem thing [] = No listEmpty
isElem thing (elem :: rest) with (Index.decEq thing elem)
  isElem thing (thing :: rest) | (Yes (Same Refl Refl)) = Yes (H (Same Refl Refl))
  isElem thing (elem :: rest) | (No contra) with (isElem thing rest)
    isElem thing (elem :: rest) | (No contra) | (Yes prf) = Yes (T prf)
    isElem thing (elem :: rest) | (No contra) | (No f) = No (notInLater contra f)
-- [ EOF ]


module QCont

import Linear.Types
import Linear.Equality
import FunExt

import Syntax.PreorderReasoning

{-
   This file implements quantitative containers, and shows the
   equivalence of initiality and induction for them.

   For convenience, we use an Idris data type to implement the
   underlying algebra and pattern matching to implement the mediating
   morphism fold, as this gives us definitional commutation rules for it.
-}

-- We fix as parameters the shape and position types
parameters (S : Type, P : S -> Type)

  -- Quantative Container || S <| P || interpretation as a functor
  public export
  F : Type -> Type
  F x = Sigma1 S (\ s => P s -<> x)

  infix 10 <$#>

  -- F is functorial
  (<$#>) : (f : x -<> y) -> (F x -<> F y)
  f <$#> (a # h) = a # (\ z => f (h z))

  alg : Type -> Type
  alg x = F x -<> x

  -- Type for initial algebra; we only use pattern matching to define fold
  data W : Type where
    Con : F W -<> W

  -- F-algebra homomorphisms
  infix 10 ==>
  infix 10 #
  data (==>) : alg x -> alg y -> Type where
    (#) : {alpha : alg x} -> {beta : alg y} ->
          (1 fun : x -<> y) ->
          (0 commutes : (arg : F x) -> fun (alpha arg) = beta (fun <$#> arg)) ->
          alpha ==> beta

  -- extracting the underlying function of the morphism
  fun : {alpha : alg x} -> {beta : alg y} -> (1 h : alpha ==> beta) -> x -<> y
  fun (f # _) = f

  -- extracting the proof that it commutes
  0 commutes : {alpha : alg x} -> {beta : alg y} -> (h : alpha ==> beta) ->
             (arg : F x) -> fun h (alpha arg) = beta (fun h <$#> arg)
  commutes ( _ # c) = c

  -- Equality of morphisms
  infix 10 =@
  0  (=@) : {alpha : alg x} -> {beta : alg y} -> (f , g : alpha ==> beta) -> Type
  f =@ g  = (arg : x) -> fun f arg = fun g arg

  0 eq_H_from_fun : {alpha : alg x} -> {beta : alg y} ->
                    (h, g : alpha ==> beta) -> h =@ g -> h = g
  eq_H_from_fun (h # commh) (g # commg) eqp with (funextW eqp)
    eq_H_from_fun (h # commh) (h # commg) eqp | Refl = lcong (\comm => h # comm) eq_comm
      where
      0 eq_comm : commh = commg
      eq_comm = funextW (\x => uip (commh x) (commg x))

  -- composition of F-algebra homomorphisms is an F-algebra homomorphism
  infix 10 .&
  (.&) : {alpha : alg x} -> {beta : alg y} -> {gamma : alg z} ->
         (beta ==> gamma) -> (alpha ==> beta) -> alpha ==> gamma
  (h # commh) .& (g # commg) = (\ 1 x => h (g x)) # comm
    where
     0 comm : (x : F x) -> h (g (alpha x)) = gamma ((\1 x => h (g x)) <$#> x)
     comm x@(s # p) = rewrite commg x in commh (g <$#> x)

  -- identity homomorphism
  id_H : (alpha : alg x) -> alpha ==> alpha
  id_H alpha = (\1 x => x) # \ (s # p) => Refl

  -- mediating map out of mu F
  fold : (alpha : alg x) -> Con ==> alpha
  fold alpha = f # \ (s # h) => Refl
    where
     f : W -<> x
     f (Con (s # h)) = alpha (s # \ p => f (h p))

  -- uniqueness of the mediating map fold
  0 uniqueness : {alpha : alg x} -> (g : Con ==> alpha) -> g = fold alpha
  uniqueness {alpha} g = eq_H_from_fun g (fold alpha) (uniq_f g)
    where
    uniq_f : {alpha : alg x} -> (g : Con ==> alpha) -> g =@ fold alpha
    uniq_f {alpha} (g # comm) (Con (s # h)) =
      trans (comm (s # h)) (cong (\ h => alpha (s # h)) (funext pointwise))
        where
        0 pointwise : (1 x : P s) -> g (h x) = fun (fold alpha) (h x)
        pointwise p = uniq_f (g # comm) (h p)

  -- fold to muF is identity
  0 id_H_eq_foldW : id_H Con = fold Con
  id_H_eq_foldW = uniqueness (id_H Con)

  -- induction principle from initiality
  parameters (0 Q : W -> Type)

    ind_alg : ((1 s : S) -> (0 h : P s -<> W) ->
               ((1 p : P s) -> Q (h p)) -<> Q (Con (s # h))) -<>
             alg (Sigma0 W Q)
    ind_alg m (s # h) = Con (fst <$#> (s # h)) # m s _ (\1 p => snd (h p))

    0 fst_ind_alg : ((1 s : S) -> (0 h : P s -<> W) ->
                     ((1 p : P s) -> Q (h p)) -<> Q (Con (s # h))) -<>
                    Con ==> Con
    fst_ind_alg m =  (\1 w => fst (fun (fold (ind_alg m)) w)) # \(s # h) => Refl

    0 id_H_eq_fia : (1 m : (1 s : S) -> (0 h : P s -<> W) ->
                     ((1 p : P s) -> Q (h p)) -<> Q (Con (s # h))) ->
                  (id_H Con = fst_ind_alg m)
    id_H_eq_fia m = trans id_H_eq_foldW (sym (uniqueness (fst_ind_alg m)))

    0 id_P_eq_fia : (1 m : (1 s : S) -> (0 h : P s -<> W) ->
                     ((1 p : P s) -> Q (h p)) -<> Q (Con (s # h))) ->
                    (id_H Con =@ fst_ind_alg m)
    id_P_eq_fia m w = lcongApp (lcong fun (id_H_eq_fia m)) w

    public export
    induction : ((1 s : S) -> (0 h : P s -<> W) ->
                 ((1 p : P s) -> Q (h p)) -<> Q (Con (s # h))) ->
                (1 w : W) -> Q w
    induction m w = replace {p = Q} (sym (id_P_eq_fia m w)) (snd (fun (fold (ind_alg m)) w))

  -- computation rule
  0 ind_comp : (0 Q : W -> Type) ->
               (m : (1 s : S) -> (0 h : P s -<> W) ->
                 ((1 p : P s) -> Q (h p)) -<> Q (Con (s # h))) ->
               (1 s : S) -> (0 h : P s -<> W) ->
               induction Q m (Con (s # h)) = m s h (\1 p => induction Q m (h p))
  ind_comp q m s h =  Calc $
    |~ induction q m (Con (s # h))
    ~~ m s h (\p => induction q m (h p))  ...(fixQ eq snd_fold)
   where
     0 fixQ : {g : W -<> W} -> (eq : (\1 x => x) = g) -> (exp : (0 w : W) -> q (g w)) ->
               replace {p = q} (sym (cong (\ g => Con (s # (\z => g (h z)))) eq))
                        (m s (\ z => g (h z)) (\1 p => exp (h p)))
              = m s h (\1 p => replace {p = q} (sym (lcongApp eq (h p))) (exp (h p)))
     fixQ Refl v = Refl

     0 fst_fold : W -<> W
     fst_fold w = fst (fun (fold (ind_alg q m)) w)

     snd_fold : (0 w : W) -> q (fst_fold w)
     snd_fold w = snd (fun (fold (ind_alg q m)) w)

     0 eq : (\1 w => w) = (\1 w => fst_fold w)
     eq = lcong fun (id_H_eq_fia q m)

  -- initiality out of induction
  initiality : (alpha : alg x) -> Con ==> alpha
  initiality alpha = (induction (\ _ => x) (\ s , _ , ih  => alpha (s # ih))) # eq
    where
      0 eq : (w : F W) ->
             induction (\ _ => x) (\ s , _ , ih => alpha (s # ih)) (Con w) =
             alpha (induction (\ _ => x) (\ s , _, ih => alpha (s # ih)) <$#> w)
      eq (s # h) = ind_comp (\ _ => x) (\s, _, ih => alpha (s # ih)) s h

  0 uniq_morphism_f : (alpha : alg x) -> (f : Con ==> alpha) ->
                      fun f = fun (initiality alpha)
  uniq_morphism_f alpha (f # comm) = funext (induction (\ z => f z = fun (initiality alpha) z) m)
    where
      0 ihp : (1 s : S) -> (0 h : P s -<> W) ->
              (1 ih : (1 p : P s) -> f (h p) = fun (initiality alpha) (h p)) ->
              (1 p : P s) ->
              f (h p) =  induction (\ _ => x) (\ s, _, ih => alpha (s # ih)) (h p)
      ihp s h ih p = ih p

      0 m : (1 s : S) -> (0 h : P s -<> W) -> (1 ih : (1 p : P s) -> f (h p) = fun (initiality alpha) (h p)) ->
           f (Con (s # h)) = fun (initiality alpha) (Con (s # h))
      m s h ih = Calc $
       |~ f (Con (s # h))
       ~~ alpha (s # \1 x => f (h x))
          ...(comm (s # h))
       ~~ alpha (s # \p => fun (initiality alpha) (h p))
          ...( cong (\ u => alpha (s # u))
                    (funext (ihp s h ih)))
       ~~ fun (initiality alpha) (Con (s # h))
          ...( sym (ind_comp (\ _ => x) (\s , _ , h => alpha (s # h)) s h))

  0 uniq_morphism_h : (alpha : alg x) -> (f : Con ==> alpha) -> f = initiality alpha
  uniq_morphism_h alpha f = eq_H_from_fun f (initiality alpha) (lcongApp (uniq_morphism_f alpha f))


> module List.Operations

> import Data.List
> import Data.List.Quantifiers
> import Syntax.PreorderReasoning

> import Sigma.Sigma
> import Fun.Operations
> -- import NumRefinements
> import Rel.TotalPreorder
> import Rel.TotalPreorderOperations

> %default total
> %access public export
> %auto_implicits on

* |List| is a functor:

> ||| fmap
> fmap : {A, B : Type} -> (A -> B) -> List A -> List B
> fmap = map

* |List| is a monad:

> ||| ret
> ret : {A : Type} -> A -> List A
> ret = pure

> ||| bind
> bind : {A, B : Type} -> List A -> (A -> List B) -> List B
> bind = (>>=)

* |List| is a container monad:

> |||
> NonEmpty    : {A : Type} -> List A -> Type
> NonEmpty  Nil      = Void
> NonEmpty (a :: as) = Unit

> idThere : {A : Type} ->
>           (a : A) -> (as : List A) ->
>           Sigma A (\ x => x `Elem` as) -> Sigma A (\ x => x `Elem` (a :: as))
> idThere a as (MkSigma x p) = MkSigma x (There p)

> ||| Tagging
> tagElem  :  {A : Type} -> (as : List A) -> List (Sigma A (\ a => a `Elem` as))
> tagElem Nil = Nil
> tagElem {A} (x :: xs) = (MkSigma x Here) :: (map (idThere x xs) (tagElem xs))

* Show

> implementation Show (Elem a as) where
>   show = show' where
>     show' : {A : Type} -> {a : A} -> {as : List A} -> Elem a as -> String
>     show'  Here     = "Here"
>     show' (There p) = "There" ++ show' p

> showlong : Show a => List a -> String
> showlong xs = "  [" ++ show' "" xs ++ "]" where
>   show' acc []        = acc
>   show' acc [x]       = acc ++ show x
>   show' acc (x :: xs) = show' (acc ++ show x ++ ",\n" ++ "   ") xs

* Reduction operators

> |||
> max : {A : Type} -> {R : A -> A -> Type} ->
>       TotalPreorder R -> (as : List A) -> List.Operations.NonEmpty as -> A
> max tp       Nil        p = absurd p
> max tp (a :: Nil)       _ = a
> max tp (a :: a' :: abs) _ with (max tp (a' :: abs) ())
>   | m with (totalPre tp a m)
>     | (Left _)  = m
>     | (Right _) = a

> |||
> argmaxMax : {A, B : Type} -> {R : B -> B -> Type} ->
>             TotalPreorder R -> (abs : List (A, B)) -> List.Operations.NonEmpty abs -> (A, B)
> argmaxMax tp       Nil                   p = absurd p
> argmaxMax tp ((a, b) :: Nil)             _ = (a, b)
> argmaxMax tp ((a, b) :: (a', b') :: abs) _ with (argmaxMax tp ((a', b') :: abs) ())
>   | (argmax, max) with (totalPre tp b max)
>     | (Left _)  = (argmax, max)
>     | (Right _) = (a, b)

> |||
> min : {A : Type} -> {R : A -> A -> Type} ->
>       TotalPreorder R -> (as : List A) -> List.Operations.NonEmpty as -> A
> {-
> min tp       Nil        p = absurd p
> min tp (a :: Nil)       _ = a
> min tp (a :: a' :: abs) _ with (min tp (a' :: abs) ())
>   | m with (totalPre tp a m)
>     | (Left _)  = a
>     | (Right _) = m
> -}
> min tp       Nil        p = absurd p
> min tp (a :: Nil)       _ = a
> min tp (a :: a' :: abs) _ with (totalPre tp a a')
>   | (Left  _) = assert_total (min tp (a  :: abs) ())
>   | (Right _) = assert_total (min tp (a' :: abs) ())

> |||
> argminMin : {A, B : Type} -> {R : B -> B -> Type} ->
>             TotalPreorder R -> (abs : List (A, B)) -> List.Operations.NonEmpty abs -> (A, B)
> argminMin tp       Nil                   p = absurd p
> argminMin tp ((a, b) :: Nil)             _ = (a, b)
> argminMin tp ((a, b) :: (a', b') :: abs) _ with (argminMin tp ((a', b') :: abs) ())
>   | (argmin, min) with (totalPre tp b min)
>     | (Left _)  = (a, b)
>     | (Right _) = (argmin, min)

> {-

> |||
> argmaxMax : {A, B : Type} -> TotalPreorder B -> (abs : List (A, B)) -> List.Operations.NonEmpty abs -> (A, B)
> argmaxMax tp       Nil                   p = absurd p
> argmaxMax tp ((a, b) :: Nil)             _ = (a, b)
> argmaxMax tp ((a, b) :: (a', b') :: abs) _ with (argmaxMax tp ((a', b') :: abs) ())
>   | (argmax, max) with (totalPre tp b max)
>     | (Left _)  = (argmax, max)
>     | (Right _) = (a, b)

> |||
> argminMin : {A, B : Type} -> TotalPreorder B -> (abs : List (A, B)) -> List.Operations.NonEmpty abs -> (A, B)
> argminMin tp       Nil                   p = absurd p
> argminMin tp ((a, b) :: Nil)             _ = (a, b)
> argminMin tp ((a, b) :: (a', b') :: abs) _ with (argminMin tp ((a', b') :: abs) ())
>   | (argmin, min) with (totalPre tp b min)
>     | (Left _)  = (a, b)
>     | (Right _) = (argmin, min)

> -}

> |||
> sumMapSnd : {A, B : Type} -> (Num B) => List (A, B) -> B
> sumMapSnd abs = sum (map snd abs)

> |||
> mapIdRightMult : {A, B : Type} -> (Num B) => (List (A, B), B) -> List (A, B)
> mapIdRightMult (abs, b) = map (cross id (* b)) abs

> |||
> mvMult : {A, A', B : Type} -> (Num B) => List (A, B) -> (A -> List (A', B)) -> List (A', B)
> mvMult abs f = concat (map (mapIdRightMult . (cross f id)) abs)
> -- mvMult            Nil  f = Nil
> -- mvMult ((a, b) :: abs) f = mapIdRightMult (f a, b) ++ mvMult abs f

> |||
> prods : {B : Type} -> (Num B) => List (B, B) -> List B
> prods = map (uncurry (*))

> |||
> sumProds : {B : Type} -> (Num B) => List (B, B) -> B
> sumProds Nil = 0
> sumProds ((b,b') :: bbs) = b * b' + sumProds bbs

* Filtering

> ||| Filters a list on a decidable property and pairs elements with proofs
> filterTagSigma : {A : Type} ->
>                  {P : A -> Type} ->
>                  ((a : A) -> Dec (P a)) ->
>                  List A ->
>                  List (Sigma A P)
> filterTagSigma d1P Nil = Nil
> filterTagSigma d1P (a :: as) with (filterTagSigma d1P as)
>   | tail with (d1P a)
>     | (Yes p) = (MkSigma a p) :: tail
>     | (No  _) = tail

> ||| Filters a list on a decidable property and pairs elements with proofs
> filterTagSubset : {A : Type} ->
>                   {P : A -> Type} ->
>                   ((a : A) -> Dec (P a)) ->
>                   List A ->
>                   List (Subset A P)
> filterTagSubset d1P Nil = Nil
> filterTagSubset d1P (a :: as) with (filterTagSubset d1P as)
>   | tail with (d1P a)
>     | (Yes p) = (Element a p) :: tail
>     | (No  _) = tail

* Ad-hoc filtering

> |||
> discardZeroes : {B : Type} -> (Num B, DecEq B) => List B -> List B
> discardZeroes  Nil      = Nil
> discardZeroes (b :: bs) with (decEq b 0)
>   | (Yes _) = discardZeroes bs
>   | (No _)  = b :: discardZeroes bs

> |||
> discardBySndZero : {A, B : Type} -> (Num B, DecEq B) => List (A, B) -> List (A, B)
> discardBySndZero  Nil      = Nil
> discardBySndZero (ab :: abs) with (decEq (snd ab) 0)
>   | (Yes _) = discardBySndZero abs
>   | (No _)  = ab :: discardBySndZero abs

> |||
> discardBySndZeroEq : {A, B : Type} -> (Num B, Eq B) => List (A, B) -> List (A, B)
> discardBySndZeroEq  Nil      = Nil
> discardBySndZeroEq (ab :: abs) with ((snd ab) == 0)
>   |  True = discardBySndZeroEq abs
>   | False = ab :: discardBySndZeroEq abs


import CatenableDeque
import FiniteMap

import BankersDeque
import ImplicitCatenableDeque

import Trie
import TrieOfTrees

data SizedD : (Type -> Type) -> Type -> Type where
  MkSized : (sz : Int) -> (d : dt a) -> SizedD dt a

ImplicitCatenableDeque.Sized (SizedD d) where
  size (MkSized sz _) = sz

subtract : Neg n => n -> n -> n
subtract y x = x - y

Deque d => Deque (SizedD d) where
  empty = MkSized 0 empty
  isEmpty (MkSized sz _) = 0 == sz
  cons x (MkSized sz d) = MkSized (1 + sz) (cons x d)
  head (MkSized _ d) = head d
  tail (MkSized sz d) = MkSized (subtract 1 sz) (tail d)
  snoc (MkSized sz d) x = MkSized (sz + 1) (snoc d x)
  last (MkSized _ d) = last d
  init (MkSized sz d) = MkSized (sz - 1) (init d)

CatenableDeque d => CatenableDeque (SizedD d) where
  (MkSized sz1 d1) ++ (MkSized sz2 d2) = MkSized (sz1 + sz2) (d1 ++ d2)

data BoolMap : Type -> Type -> Type where
  BM : (Maybe a, Maybe a) -> BoolMap Bool a

FiniteMap BoolMap Bool where
  empty = BM (Nothing, Nothing)
  bind False x (BM t) = BM (Just x, snd t)
  bind True x (BM t) = BM (fst t, Just x)
  lookup False (BM t) = fst t
  lookup True (BM t) = snd t


module Data.Vect.Structural

-- For structural lemmas about (Vect) modules
import Control.Algebra
import Control.Algebra.VectorSpace -- definition of module
import Classes.Verified -- definition of verified algebras other than modules
import Control.Algebra.DiamondInstances
import Data.Matrix
import Data.Matrix.Algebraic -- module instances; from Idris 0.9.20

%default total

{-
Theorem (vecHeadtailsEq) for proving equality of (Vect)s by proving equality of their heads and tails. Often used after (headtails).

Theorem (vecIndexwiseEq) for proving equality of (Vect)s by proving indexwise equality of their entries.
-}

vecHeadtailsEq : {xs,ys : Vect _ _} -> ( headeq : x = y ) -> ( taileq : xs = ys ) -> x::xs = y::ys
vecHeadtailsEq {x} {xs} {ys} headeq taileq = trans (vectConsCong x xs ys taileq) $ cong {f=(::ys)} headeq
-- Also a solid proof:
-- vecHeadtailsEq {x} {xs} {ys} headeq taileq = trans (cong {f=(::xs)} headeq) $ replace {P=\l => l::xs = l::ys} headeq $ vectConsCong x xs ys taileq

vecIndexwiseEq : ((i : Fin _) -> index i xs = index i ys) -> xs = ys
vecIndexwiseEq fn {xs=[]} {ys=[]} = Refl
vecIndexwiseEq fn {xs=x::xs} {ys=y::ys} = vecHeadtailsEq (fn FZ) $ vecIndexwiseEq {xs=xs} {ys=ys} (\i => fn $ FS i)

{-
* Theorems characterizing (Vect)s of degenerate qualities.
* Theorems characterizing the index or head of a list created with a certain operation.
* The theorem (weakenedInd) about comparing an index of a list to an index of its (init).
* The theorem (extensionalEqToMapEq) extending an extensional equality between functions to one between their (map)s over (Vect)s.
-}

total
zeroVecEq : {a : Vect 0 r} -> {b : Vect 0 r} -> a = b
zeroVecEq {a=[]} {b=[]} = Refl

total
vecSingletonReplicateEq : ((u : a) -> v=u) -> (xs : Vect n a) -> (xs = replicate n v)
vecSingletonReplicateEq f [] = Refl
vecSingletonReplicateEq f (x::xs) {v} = rewrite sym (f x) in cong {f=(v::)} (vecSingletonReplicateEq f xs)

total
zeroVecVecId : (xs : Vect n (Vect 0 a)) -> (xs = replicate n [])
zeroVecVecId = vecSingletonReplicateEq (\b => zeroVecEq {a=[]} {b=b})

total
headMapChariz : {xs : Vect (S n) _} -> head $ map f xs = f $ head xs
headMapChariz {xs=x::xs} = Refl

mapheadrec : with Data.Vect ( map head (v::vs) = (head v) :: (map head vs) )
mapheadrec = Refl

headtails : (v : Vect (S predk) _) -> v = (head v) :: (tail v)
headtails (vv::vvs) = Refl

-- The theorem below this one should not be a necessary weakening, since the functions have equivalent definitions.
-- indexFZIshead : index FZ = Data.Vect.head

total
indexFZIsheadValued : index FZ xs = head xs
indexFZIsheadValued {xs=x :: xs} = Refl

indexReplicateChariz : Data.Vect.index k $ replicate n a = a
indexReplicateChariz {n=Z} {k} = FinZElim k
indexReplicateChariz {n=S predn} {k=FZ} = Refl
indexReplicateChariz {n=S predn} {k=FS prelk} = indexReplicateChariz {k=prelk}

uniformValImpliesReplicate : (a : ty) -> (x : Vect n ty) -> ((i : _) -> index i x = a) -> x = replicate n a
uniformValImpliesReplicate a [] fn = Refl
uniformValImpliesReplicate a (x::xs) fn = vecHeadtailsEq (fn FZ) $ uniformValImpliesReplicate a xs (\i => fn $ FS i)

indexMapChariz : Data.Vect.index k $ map f xs = f $ index k xs
indexMapChariz {xs=[]} {k} = FinZElim k
-- indexMapChariz {xs} {f} {k=FZ} = trans indexFZIsheadValued $ trans headMapChariz $ sym $ cong indexFZIsheadValued
indexMapChariz {xs=x::xs} {f} {k=FZ} = Refl
indexMapChariz {xs=x::xs} {f} {k=FS k} = indexMapChariz {xs=xs} {f=f} {k=k}

indexUpdateAtChariz : index i $ updateAt i f xs = f $ index i xs
indexUpdateAtChariz {xs=[]} {i} = FinZElim i
indexUpdateAtChariz {xs=(x::xs)} {f} {i=FZ} = Refl
indexUpdateAtChariz {xs=x::xs} {f} {i=FS i} = indexUpdateAtChariz {xs=xs} {f=f} {i=i}

indexUpdateAtChariz2 : Not (i = j) -> index i $ updateAt j f xs = index i xs
indexUpdateAtChariz2 prneq {i=FZ} {j=FZ} = void $ prneq Refl
indexUpdateAtChariz2 prneq {i=FS k} {j=FZ} {xs=x::xs} = Refl
indexUpdateAtChariz2 prneq {i=FZ} {j=FS k} {xs=x::xs} = Refl
indexUpdateAtChariz2 prneq {i=FS ki} {j=FS kj} {xs=x::xs} = indexUpdateAtChariz2 {xs=xs}
	$ prneq . (cong {f=FS})

updateDeleteAtChariz : deleteAt i $ updateAt i f xs = deleteAt i xs
updateDeleteAtChariz {i=FZ} {xs=x::xs} = Refl
updateDeleteAtChariz {i=FS k} {xs=x::[]} = FinZElim k
updateDeleteAtChariz {i=FS k} {xs=x::x2::xs} = cong {f=(x::)}
	$ updateDeleteAtChariz {i=k} {xs=x2::xs}

updateAtIndIsMapAtInd : index i $ updateAt i f xs = index i $ map f xs
updateAtIndIsMapAtInd = trans indexUpdateAtChariz $ sym indexMapChariz

deleteSuccRowVanishesUnderHead : head $ deleteRow (FS k) xs = head xs
deleteSuccRowVanishesUnderHead {xs=x::xs} = Refl

updateAtSuccRowVanishesUnderHead : head $ updateAt (FS k) f xs = head xs
updateAtSuccRowVanishesUnderHead {xs=x::xs} = Refl

zipWithEntryChariz : index i $ Vect.zipWith m x y = m (index i x) (index i y)
zipWithEntryChariz {x=[]} {y=[]} {i} = FinZElim i
zipWithEntryChariz {x=(x::xs)} {y=(y::ys)} {i=FZ} = Refl
zipWithEntryChariz {x=(x::xs)} {y=(y::ys)} {i=FS preli} = zipWithEntryChariz {x=xs} {y=ys} {i=preli}

plusOneVectIsSuccVect : Vect (n+1) a = Vect (S n) a
plusOneVectIsSuccVect {a} {n} = sym $ cong {f=\k => Vect k a} $ trans (cong {f=S} $ sym $ plusZeroRightNeutral n) $ plusSuccRightSucc n Z

{-
appendedSingletonAsSuccVect : (xs : Vect n a) -> (v : a) -> Vect (S n) a
appendedSingletonAsSuccVect {a} {n} xs v = rewrite sym $ plusOneVectIsSuccVect {a=a} {n=n} in (xs++[v])
-}
appendedSingletonAsSuccVect : (xs : Vect n a) -> (v : a) -> Vect (S n) a
appendedSingletonAsSuccVect [] v = [v]
appendedSingletonAsSuccVect (x::xs) v = x::appendedSingletonAsSuccVect xs v

-- With the old implementation of (appendedSingletonAsSuccVect) this seemed impossible to prove.
consAppendedSingleton : {xs : Vect n a} -> appendedSingletonAsSuccVect (x::xs) v = x::appendedSingletonAsSuccVect xs v
consAppendedSingleton {x} {xs} {v} {a} {n} = Refl

{-
-- Too many problems with this, rewriting the types to handle Nat addition.
lastInd : {xs : Vect n a} -> Data.Vect.index Data.Fin.last (rewrite sym $ plusOneVectIsSuccVect {a=a} {n=n} in (xs++[v])) = v
-}

{-
-- Stopped typechecking once the implementation of (appendedSingletonAsSuccVect) changed.
lastInd : {xs : Vect n a} -> index Data.Fin.last $ appendedSingletonAsSuccVect xs v = v
lastInd {xs=[]} = Refl
lastInd {xs=x::xs} {v} = rewrite consAppendedSingleton {x=x} {xs=xs} {v=v} in (lastInd {xs=xs} {v=v})

-----

"ERROR ON INTROS" BUG, CASE, SOLUTION

---

> lastInd {xs=x::xs} = ?lastInd_rhs_2

> :prove lastInd_rhs_2
lastInd_rhs_2> intro

Type mismatch between
        Vect k a = Vect k a
and
        Vect (S (S k)) a = Vect (S (plus k 1)) a

which I think means the type signature for (lastInd) is being reanalyzed in the presence of (x::xs), as if inlined, in such a way that the sucessor to rewrite is the one inside rather than outside, or something.

This works fine:

> lastInd {xs=x::xs} {v} = the ( (index Data.Fin.last $ appendedSingletonAsSuccVect (x::xs) v) = v ) ?lastInd_rhs_2

and spells out

> lastInd {xs=x::xs} {v} = the ( (index Data.Fin.last $ appendedSingletonAsSuccVect (x::xs) v) = v ) ( rewrite consAppendedSingleton {x=x} {xs=xs} {v=v} in lastInd {xs=xs} {v=v} )

-}

-- Could this be done with the reversal isomorphism of each Fin?
lastInd : {xs : Vect n a} -> index Data.Fin.last $ appendedSingletonAsSuccVect xs v = v
lastInd {xs=[]} = Refl
lastInd {xs=x::xs} {v} = lastInd {xs=xs} {v=v}

{-
-- Stopped typechecking once the implementation of (appendedSingletonAsSuccVect) changed.
total
weakenedInd : {xs : Vect n a} -> index (weaken k) $ appendedSingletonAsSuccVect xs v = index k xs
weakenedInd {xs=[]} {k} = absurd k
weakenedInd {xs=x::xs} {k=FZ} {v} = rewrite consAppendedSingleton {x=x} {xs=xs} {v=v} in Refl
weakenedInd {xs=x::xs} {k=FS j} {v} = rewrite consAppendedSingleton {x=x} {xs=xs} {v=v} in weakenedInd {xs=xs} {k=j} {v}
-}

{-
Could this be done with the reversal isomorphism of each Fin and a proof that weaken becomes FS under it?
-}
total
weakenedInd : {xs : Vect n a} -> index (weaken k) $ appendedSingletonAsSuccVect xs v = index k xs
weakenedInd {xs=[]} {k} = absurd k
weakenedInd {xs=x::xs} {k=FZ} {v} = Refl
weakenedInd {xs=x::xs} {k=FS j} {v} = weakenedInd {xs=xs} {k=j} {v}

extensionalEqToMapEq : (exteq : (a : ty) -> (f a = g a)) -> (xs : Vect n ty) -> (map f xs = map g xs)
extensionalEqToMapEq exteq [] = Refl
extensionalEqToMapEq exteq (x::xs) = vecHeadtailsEq (exteq x) $ extensionalEqToMapEq exteq xs

-- Functorial nature of (map).
composeUnderMap : (v : Vect n a)
	-> (g : b -> c)
	-> (f : a -> b)
	-> map g $ map f v = map (g . f) v
composeUnderMap [] g f = Refl
composeUnderMap (v::vs) g f = vecHeadtailsEq Refl $ composeUnderMap vs g f

{-
Theorems about the module (Vect n a) over a ring (a):
* Compatibility between the operations of the ring (a) and of (Vect n a) as a module under (index).
-}

indexNeutralIsNeutral1D : Ring a => (k : Fin n) -> index k $ Algebra.neutral {a=Vect n a} = Algebra.neutral
indexNeutralIsNeutral1D FZ = Refl
indexNeutralIsNeutral1D (FS k) = indexNeutralIsNeutral1D k

-- For completeness's sake, these should have (index FZ) as (head) forms proved.

indexCompatInverse : VerifiedRingWithUnity a => (xs : Vect n a) -> (i : Fin n) -> index i $ inverse xs = inverse $ index i xs
indexCompatInverse [] i = FinZElim i
indexCompatInverse (x::xs) FZ = Refl
indexCompatInverse (x::xs) (FS preli) = indexCompatInverse xs preli

indexCompatAdd : VerifiedRingWithUnity a => (xs, ys : Vect n a) -> (i : Fin n) -> index i $ xs <+> ys = index i xs <+> index i ys
indexCompatAdd xs ys i = zipWithEntryChariz {x=xs} {y=ys} {i=i} {m=(<+>)}

indexCompatSub : VerifiedRingWithUnity a
	=> {auto ok :
		((<+>) @{vrwuSemigroupByGrp $ the (VerifiedRingWithUnity a) %instance})
		= ((<+>) @{vrwuSemigroupByVMon $ the (VerifiedRingWithUnity a) %instance})
		}
	-> (xs, ys : Vect n a)
	-> (i : Fin n)
	-> index i $ xs <-> ys = index i xs <-> index i ys
indexCompatSub {ok} xs ys i = rewrite ok in
	trans (indexCompatAdd xs (inverse ys) i)
	$ cong {f=((index i xs)<+>)}
	$ indexCompatInverse ys i

indexCompatScaling : VerifiedRingWithUnity a
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> (r : a) -> (xs : Vect n a) -> (i : Fin n)
	-> index i $ r <#> xs = r <.> index i xs
indexCompatScaling r [] i = FinZElim i
indexCompatScaling r (x::xs) FZ {ok} = cong {f=\t => t r x} ok
indexCompatScaling r (x::xs) (FS preli) = indexCompatScaling r xs preli

{-
* The recursive equation for (foldr) over (Vect)s.
* The recursive equation for sums in (Monoid)s over a (Vect _).
-}

foldrImplRec : (f : t -> acc -> acc) -> (e : acc) -> (go : acc -> acc) -> (x : t) -> (xs : Vect n t) -> (foldrImpl f e go (x::xs) = go $ f x $ foldrImpl f e Basics.id xs)
foldrImplRec f e go x [] = Refl
foldrImplRec f e go x (xx::xxs) = trans (foldrImplRec f e (go . (f x)) xx xxs) $ cong {f=go . (f x)} $ sym $ foldrImplRec f e id xx xxs

monoidrec : Monoid a => (v : a) -> (vs : Vect n a) -> sum' (v::vs) = v <+> sum' vs
monoidrec = foldrImplRec (<+>) Algebra.neutral id


module Control.Algebra.ZZDivisors

import Control.Algebra
import Classes.Verified
import Control.Algebra.VectorSpace -- definition of module

import Data.Matrix
import Data.Matrix.Algebraic -- module instances; from Idris 0.9.20
import Data.Matrix.AlgebraicVerified

import Data.Vect.Structural
import Data.Matrix.Structural

import Data.ZZ
import Control.Algebra.NumericInstances
import Control.Algebra.ZZVerifiedInstances
import Data.Matrix.ZZVerified

import Data.Matrix.ZZModuleSpan
import Data.Matrix.LinearCombinations

%default total

{-
Trivial lemmas and plumbing
-}

bileibniz : (f : a -> b -> c) -> (x1=x2) -> (y1=y2) -> f x1 y1 = f x2 y2
bileibniz f {x1} {x2} {y1} {y2} xeq yeq = rewrite (cong {f=f} xeq) in cong {f=f x2} yeq

{-
A divisibility relation
-}

-- Should be modified to account for (gcd x 0 = 0).
quotientOverZZ : ZZ -> ZZ -> Type
quotientOverZZ x y = ( d : ZZ ** d<.>y=x )

quotientOverZZrefl : x `quotientOverZZ` x
quotientOverZZrefl {x} = ( unity ** ringWithUnityIsUnityR x )

quotientOverZZtrans : x `quotientOverZZ` y -> y `quotientOverZZ` z -> x `quotientOverZZ` z
quotientOverZZtrans (dx ** prx) (dy ** pry) {x} {y} {z} = ( dx<.>dy ** trans (sym $ ringOpIsAssociative dx dy z) $ trans (cong pry) prx )

quotientOverZZreflFromEq : (a=b) -> a `quotientOverZZ` b
quotientOverZZreflFromEq {a} {b} eq with (quotientOverZZrefl {x=b})
	| (d ** pr) = (d ** trans pr $ sym eq)

{-
Interactions between integer divisibility and linear combinations
-}

||| Examples:
|||
||| > divisorByDistrib (Pos 4) ((Pos 8)::(Pos 0)::[]) (\x => case x of { FZ => (Pos 2 ** Refl); (FS FZ) => (Pos 0 ** Refl) })
|||
||| (Pos 2 ** ?divisorByDistrib_pr) : (d : ZZ ** multZ d (Pos 4) = Pos 8)
|||
||| > divisorByDistrib (Pos 4) ((Pos 8)::(Pos 4)::[]) (\x => case x of { FZ => (Pos 2 ** Refl); (FS FZ) => (Pos 1 ** Refl) })
|||
||| (Pos 3 ** ?divisorByDistrib_pr) : (d : ZZ ** multZ d (Pos 4) = Pos 12)
|||
||| > divisorByDistrib (Pos 4) ((Pos 8)::(Pos 1)::[]) (\x => case x of { FZ => (Pos 2 ** Refl); (FS FZ) => (Pos 0 ** Refl) })
|||
||| ... Type mismatch between 0 and 1
divisorByDistrib : (z : ZZ)
	-> (x : Vect n ZZ)
	-> ( (k : _) -> index k x `quotientOverZZ` z )
	-> (LinearCombinations.monoidsum x) `quotientOverZZ` z
divisorByDistrib z [] fn = (0 ** ringNeutralIsMultZeroL z)
{-
-- Doesn't like the (fn . FS) passed to divisorByDistrib in the recursive step.
divisorByDistrib z (xx::xxs) fn with ( divisorByDistrib z xxs (fn . FS) )
	| (dxxs ** prxxs) with (fn FZ)
		| (dxx ** prxx) = (dxx<+>dxxs ** ?divisorByDistrib_pr)
	-- divisorByDistrib_pr {z} {xx} {xxs} {fn} {dxx} {dxxs} =
	-- 	(dxx<+>dxxs)<.>z	={ ringOpIsDistributiveR dxx dxxs z }=
	-- 	(dxx<.>z)<+>(dxxs<.>z)	={ cong {f=((dxx<.>z)<+>)} prxxs }=
	-- 	(dxx<.>z)<+>sum xxs	={ cong {f=(<+>_)} prxx }=
	-- 	xx<+>sum xxs	={ rewrite sym $ monoidrec1D {v=xx} {vs=xxs} }=
	-- 	sum (x::xxs)	QED
-}
divisorByDistrib z (xx::xxs) {n=S predn} fn = ( dxx<+>dxxs ** divisorByDistrib' )
	where
		dxx : ZZ
		dxx = getWitness $ fn FZ
		prxx : dxx<.>z = xx
		prxx = getProof $ fn FZ
		dxxs : ZZ
		-- Passing (fn . FS) as an arg during proof reqs implicit arg (n).
		{-
		In REPL: "No such variable __pi_arg7"
		Otherwise:
		"Type mismatch between
			(k1 : Fin (S k)) ->
			quotientOverZZ (index k1 (xx :: xxs)) z (Type of fn)
		and
			Fin (S k) ->
			(\k1 =>
				quotientOverZZ (index k1 xxs) z) (__pi_arg7) (Expected type)

		Specifically:
			Type mismatch between
				index v1 (xx :: xxs)
			and
				index (__pi_arg7) xxs
		"

		> dxxs = getWitness $ divisorByDistrib z xxs (fn . FS)
		-}
		dxxs = getWitness $ divisorByDistrib z xxs (\i => fn (FS i))
		prxxs : dxxs<.>z = LinearCombinations.monoidsum xxs
		-- prxxs = getProof $ divisorByDistrib z xxs (fn . FS)
		prxxs = getProof $ divisorByDistrib z xxs (\i => fn (FS i))
		{-
		If you only write the following (note the missing (<.>_) from (_<.>_ = _))

		> divisorByDistrib' : (dxx<+>dxxs) = LinearCombinations.monoidsum (xx::xxs)

		then you get a type mismatch error that looks like

		"type mismatch between _ and _, specifically between

			foldrImpl (flip plusZ) (Pos 0) (plusZ xx) xxs

		and

			foldrImpl (flip plusZ) (Pos 0) (plusZ xx) xxs
		"

		which is not at all what's wrong, and is an unhelpful error message.
		-}
		divisorByDistrib' : (dxx<+>dxxs)<.>z = LinearCombinations.monoidsum (xx::xxs)
		divisorByDistrib' = trans (ringOpIsDistributiveR dxx dxxs z) $ trans (bileibniz (<+>) prxx prxxs) $ sym $ monoidrec1D {v=xx} {vs=xxs}

{-
We need to modify this formula to make the right-hand-argument of (quotientOverZZ) constant. It should perhaps be saying the (quotientOverZZ)'s right-hand-arg lies in the transpose of xs in a constant position.
-}
zipWithHeadsQuotientRelation : {zs : Vect (S predn) ZZ} -> {xs : Matrix (S predn) (S predm) ZZ} -> (k : _ ) -> ( index k $ map head $ zipWith (<#>) zs xs ) `quotientOverZZ` (head $ index k xs)
zipWithHeadsQuotientRelation {zs=z::zs} {xs=(xx::xxs)::xs} FZ = (z ** Refl)
zipWithHeadsQuotientRelation {zs=z::zs} {xs=(xx::xxs)::xs} {predn=Z} (FS prelk) = FinZElim prelk
zipWithHeadsQuotientRelation {zs=z::zs} {xs=x::xs} {predn=S prededn} (FS prelk) = zipWithHeadsQuotientRelation {zs=zs} {xs=xs} {predn=prededn} prelk

-- Should be applied to (fn) as given by the gcd equality.
zipWithHeadsQuotientRelation2 : {zs : Vect (S predn) ZZ} -> {xs : Matrix (S predn) (S predm) ZZ} -> ( fn : ( i : Fin _ ) -> (head $ Vect.index i xs) `quotientOverZZ` (head $ Vect.head xs) ) -> (k : _ ) -> ( Vect.index k $ map head $ Vect.zipWith (<#>) zs xs ) `quotientOverZZ` (head $ Vect.head xs)
zipWithHeadsQuotientRelation2 {zs} {xs} fn k = quotientOverZZtrans (zipWithHeadsQuotientRelation {zs=zs} {xs=xs} k) (fn k)

linearComboQuotientRelation : (x : Vect (S predm) ZZ) -> (xs : Matrix predn (S predm) ZZ) -> (z : Vect (S predn) ZZ)
	-> ( fn : ( i : Fin _ ) -> (head $ Vect.index i (x::xs)) `quotientOverZZ` (head x) )
	-> ( LinearCombinations.monoidsum $
			map head $
			zipWith (<#>) z (x::xs) )
		`quotientOverZZ` (head x)
linearComboQuotientRelation x xs z fn = divisorByDistrib _ _ (zipWithHeadsQuotientRelation2 {zs=z} {xs=x::xs} fn)

-- Motivation: succImplWknStep_Qfunclemma
linearComboQuotientRelation_corrollary : (x : Vect (S predm) ZZ) -> (xs : Matrix predn (S predm) ZZ) -> (z : Vect (S predn) ZZ)
	-> ( fn : ( i : Fin _ ) -> (head $ Vect.index i (x::xs)) `quotientOverZZ` (head x) )
	-> ( head $
			LinearCombinations.monoidsum $
			zipWith (<#>) z (x::xs) )
		`quotientOverZZ` (head x)
linearComboQuotientRelation_corrollary x xs z fn = quotientOverZZtrans (quotientOverZZreflFromEq $ headOfSumIsSumOfHeads _) $ linearComboQuotientRelation x xs z fn


module Data.IxRel

%access public export
%default total

||| Indexed binary relations
data IxRel : (a -> b -> c) -> c -> a -> b -> Type where
  MkIxRel : IxRel p (p a b) a b

||| A binary boolean predicate
Predicate : (a -> b -> Bool) -> a -> b -> Type
Predicate p x y = IxRel p True x y

||| Given parameters, constructs the index and relation
relate : (p : a -> b -> c) -> (x : a) -> (y : b) -> (q ** IxRel p q x y)
relate p x y = (p x y ** MkIxRel)

||| Helper for decide
private
unique : IxRel p w x y -> IxRel p q x y -> w = q
unique MkIxRel MkIxRel = Refl

||| Given parameters and an index, decides if a relation exists for that index
decide : DecEq c => (p : a -> b -> c) -> (w : c) -> (x : a) -> (y : b) -> Dec (IxRel p w x y)
decide p w x y with (relate p x y)
  | (q ** pf) =
    case decEq w q of
      Yes pfe => Yes (rewrite pfe in pf)
      No contra => No (\r => contra (unique r pf))

||| Decide specialized to predicates
decidePredicate : (p : a -> b -> Bool) -> (x : a) -> (y : b) -> Dec (Predicate p x y)
decidePredicate p x y = decide p True x y