||| Binary representation of natural numbers.
module BiNat

%access public export
%default total

data Bit = O | I

infixl 7 -:

data BiNat : Type where
  ||| Leading one bit
  J : BiNat

  ||| Append a bit to a BiNat.
  ||| `J -: O -: I -: I` corresponds to `1011`.
  (-:) : BiNat -> Bit -> BiNat

Uninhabited (J = n -: b) where
  uninhabited Refl impossible
Uninhabited (n -: b = J) where
  uninhabited Refl impossible
Uninhabited (m -: O = n -: I) where
  uninhabited Refl impossible
Uninhabited (m -: I = n -: O) where
  uninhabited Refl impossible

succ' : BiNat -> List Bit -> BiNat
succ' J        acc = foldl (-:) (J -: O) acc
succ' (n -: O) acc = foldl (-:) (n -: I) acc
succ' (n -: I) acc = succ' n (O :: acc)

||| The successor of a natural number.
succ : BiNat -> BiNat
succ n = succ' n []

pred' : BiNat -> List Bit -> BiNat
pred' J              acc = foldl (-:) J acc
pred' (n -: I)       acc = foldl (-:) (n -: O) acc
pred' (J -: O)       acc = foldl (-:) J acc
pred' (ns -: n -: O) acc = pred' (ns -: n) (I :: acc)

||| The predecessor of a natural number, but `pred J` is `J`.
pred : BiNat -> BiNat
pred n = pred' n []

nextCarry : Bit -> Bit -> Bit -> Bit
nextCarry I I I = I
nextCarry I I O = I
nextCarry I O I = I
nextCarry O I I = I
nextCarry _ _ _ = O

nextAcc : Bit -> Bit -> Bit -> Bit
nextAcc O O O = O
nextAcc O I I = O
nextAcc I O I = O
nextAcc I I O = O
nextAcc _ _ _ = I

plus' : BiNat -> BiNat -> Bit -> List Bit -> BiNat
plus' J         J         c acc = foldl (-:) (J -: c) acc
plus' J         ns        O acc = succ' ns acc
plus' J         (ns -: n) I acc = succ' ns (n :: acc)
plus' ms        J         O acc = succ' ms acc
plus' (ms -: m) J         I acc = succ' ms (m :: acc)
plus' (ms -: m) (ns -: n) c acc = plus' ms ns (nextCarry m n c) (nextAcc m n c :: acc)

||| Add two natural numbers.
plus : BiNat -> BiNat -> BiNat
plus m n = plus' m n O []

mult' : BiNat -> BiNat -> BiNat -> BiNat
mult' J         added acc = pred (plus added acc)
mult' (ms -: O) added acc = mult' ms (added -: O) acc
mult' (ms -: I) added acc = mult' ms (added -: O) (plus added acc)

||| Multiply natural numbers.
mult : BiNat -> BiNat -> BiNat
mult m n = mult' m n J

||| Convert an Integer to a BiNat, mapping non-positive numbers to J.
fromInteger : Integer -> BiNat
fromInteger i = if i <= 1 then J else fromInteger' i [] where
  fromInteger' : Integer -> List Bit -> BiNat
  fromInteger' 1 acc = foldl (-:) J acc
  fromInteger' i acc =
    fromInteger'
      (assert_smaller i (assert_total (div i 2)))
      ((if assert_total (mod i 2) == 0 then O else I) :: acc)

||| Convert a BiNat to an Integer.
toInteger : BiNat -> Integer
toInteger n = toInteger' n 1 0 where
  toInteger' : BiNat -> Integer -> Integer -> Integer
  toInteger' J         added acc = added + acc
  toInteger' (ns -: O) added acc = toInteger' ns (added * 2) acc
  toInteger' (ns -: I) added acc = toInteger' ns (added * 2) (acc + added)

tailToBiNat : List Bit -> BiNat
tailToBiNat []          = J
tailToBiNat (O :: tail) = tailToBiNat tail
tailToBiNat (I :: tail) = foldl (-:) J tail

minus' : BiNat -> BiNat -> List Bit -> BiNat
minus' J          J         tail = tailToBiNat tail
minus' J          ns        tail = J
minus' (J -: O)   J         tail = foldl (-:) J tail
minus' (ms -: O)  J         tail = foldl (-:) (pred ms -: I) tail
minus' (ms -: I)  J         tail = foldl (-:) (ms -: O) tail
minus' (ms -: O)  (ns -: O) tail = minus' ms ns (O :: tail)
minus' (J -: O)   (ns -: I) tail = J
minus' (ms -: O)  (ns -: I) tail = minus' (pred ms) ns (I :: tail)
minus' (ms -: I)  (ns -: O) tail = minus' ms ns (I :: tail)
minus' (ms -: I)  (ns -: I) tail = minus' ms ns (O :: tail)

||| Subtract natural numbers. If the second number is larger than or equal to the first, return J.
minus : BiNat -> BiNat -> BiNat
minus m n = minus' m n []

Eq BiNat where
  J         == J         = True
  (ns -: O) == (ms -: O) = ns == ms
  (ns -: I) == (ms -: I) = ns == ms
  _         == _         = False

||| Proofs that a BiNat is strictly less than another BiNat.
data LT : BiNat -> BiNat -> Type where
  JLT : (ns : BiNat) -> (n : Bit) -> LT J (ns -: n)
  LTLeading : (ms, ns : BiNat) -> ms = ns -> LT (ms -: O) (ns -: I)
  LTAppend : (ms, ns : BiNat) -> LT ms ns -> (m, n : Bit) -> LT (ms -: m) (ns -: n)

||| Strict greater than
GT : BiNat -> BiNat -> Type
GT m n = LT n m

Uninhabited (LT n J) where
  uninhabited JLT       impossible
  uninhabited LTLeading impossible
  uninhabited LTAppend  impossible

||| Less than or equal to
data LTE : BiNat -> BiNat -> Type where
  LTEEqual : (m, n : BiNat) -> m = n -> LTE m n
  LTELessThan : (m, n : BiNat) -> LT m n -> LTE m n

||| Greater than or equal to
GTE : BiNat -> BiNat -> Type
GTE m n = LTE n m

compare' : BiNat -> BiNat -> Ordering -> Ordering
compare' J         J         last = last
compare' J         (ns -: n) last = LT
compare' (ms -: m) J         last = GT
compare' (ms -: O) (ns -: O) last = compare' ms ns last
compare' (ms -: O) (ns -: I) last = compare' ms ns LT
compare' (ms -: I) (ns -: O) last = compare' ms ns GT
compare' (ms -: I) (ns -: I) last = compare' ms ns last

Ord BiNat where
  compare m n = compare' m n EQ

Num BiNat where
  (+) = plus
  (*) = mult
  fromInteger = BiNat.fromInteger


data Shape = ||| A triangle, with its base length and height
             Triangle Double Double
           | ||| A rectangle, with its length and height
              Rectangle Double Double
           | ||| A circle, with its radius
             Circle Double

area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius

data Picture = Primitive Shape
             | Combine Picture Picture
             | Rotate Double Picture
             | Translate Double Double Picture

testPic1 : Picture
testPic1 = Combine (Primitive (Triangle 2 3))
                   (Primitive (Triangle 2 4))

testPic2 : Picture
testPic2 = Combine (Primitive (Rectangle 1 3))
                   (Primitive (Circle 4))

data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)

%name Tree tree, tree1

insert : Ord elem => elem -> Tree elem -> Tree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right)
    = case compare x val of
           LT => Node (insert x left) val right
           EQ => orig
           GT => Node left val (insert x right)

-- Exercise 1
listToTree : Ord a => List a -> Tree a
listToTree [] = Empty
listToTree (x :: xs) = insert x (listToTree xs)

-- Exercise 2
-- The function `treeToList` does an in-order traversal of a tree.
treeToList : Ord a => Tree a -> List a
treeToList Empty = []
treeToList (Node left x right) = (treeToList left) ++ x :: treeToList right

-- Exercise 3
data Expr = Val Integer
          | Add Expr Expr
          | Sub Expr Expr
          | Mul Expr Expr
-- Exercise 4
evaluate : Expr -> Integer
evaluate (Val x) = x
evaluate (Add x y) = evaluate x + evaluate y
evaluate (Sub x y) = evaluate x - evaluate y
evaluate (Mul x y) = evaluate x * evaluate y

-- Exercise 5
maybeMax : Ord a => Maybe a -> Maybe a -> Maybe a
maybeMax Nothing Nothing = Nothing
maybeMax Nothing (Just x) = Just x
maybeMax (Just x) Nothing = Just x
maybeMax (Just x) (Just y) = Just $ max x y

-- Exercise 6
biggestTriangle : Picture -> Maybe Double
biggestTriangle (Primitive tri@(Triangle x y)) = Just $ area tri
biggestTriangle (Primitive _) = Nothing
biggestTriangle (Combine pic1 pic2) = maybeMax (biggestTriangle pic1) (biggestTriangle pic2)
biggestTriangle (Rotate x pic) = biggestTriangle pic
biggestTriangle (Translate x y pic) = biggestTriangle pic


||| Algebra.Magma: A representation of magmas.
|||
||| A magma is more-or-less the simplest non-trivial example of a algebraic
||| structure. It is simply a set together with a lawless binary operation over
||| it. More formally, it is *any* pair
||| \\(\mathscr{M} = (M:\mathscr{V}, \* : M^2 \to M)\\). It doesn't matter what
||| the function \\(\*\\) is. It can have any properties whatsoever; the only
||| reuirement is that it be a function of the specified type. That is, it must
||| be a total co-injective relation with domain \\(M^2\\) and codomain \\(M\\),
||| where by \"co-injective\" I mean that for every input, there is no more than
||| one output. Together with totality, which states that every input has at
||| least one output, this means that a function is a relation where every input
||| has exactly one output.
|||
||| Magmas aren't especially interesting in and of themselves. Because there are
||| no magma axioms, just a type, there isn't much that can be said about magmas
||| in general. However, they give a useful way to talk about other algebraic
||| structures. A group, for example, is a magma satisfying certain laws. In
||| other words, talking in terms of magmas and related lawless algebraic
||| structures just gives us a more convenient way to talk about the signature
||| of the more interesting ones. (Of course, all of this leads naturally to
||| groups, semigroups, monoids, etc. being extensions of the `Magma`
||| record.)
|||
||| That's not to say there's nothing interesting about magmas. There are
||| interesting combinatorial questions arising from freely generated magmas.
||| That is, consider a magma generated by three elements, \\(a, b, c\\). By
||| \"freely generated\", we mean that there are no equalities except those
||| directly entailed by the axioms; since there aren't any axioms, there aren't
||| any (non-reflexive) equalities! E.g., in a freely generated magma, we know
||| that \\((x\*y)\*z \neq x\*(y\*z)\\) for every \\(x, y, z\\). If they were
||| equal, it would still be a magma, but not a freely generated one. Now, for
||| the free magma with 3 generating elements, how many elements are there with
||| exactly \\(k\\) applications of the operation \\(\*\\)? Or more generally,
||| what if there are \\(n\\) generating elements? If you like combinatorics,
||| you might enjoy working these and related questions out\-\-\-and, as usual,
||| there's a connection to the Catalan numbers.
module Algebra.Magma

%default total

infix 7 |*|

||| The record representing magmas. Note that there are no proofs to be
||| automatically filled in; magmas don't have any extra properties beyond their
||| signature.
public export
record Magma where
  constructor MkMagma
  Set' : Type
  op'  : Set' -> Set' -> Set'

public export
Set : {magma : Magma} -> Type
Set {magma} = Set' magma

public export
(|*|) : {magma : Magma} -> Set {magma} -> Set {magma} -> Set {magma}
(|*|) {magma} = op' magma

{-
public export
AddMagma : (Num ty) => Magma
AddMagma {ty} = MkMagma ty (+)

public export
MultMagma : (Num ty) => Magma
MultMagma {ty} = MkMagma ty (*)

-- -}

-- data Magma : (Set : Type) -> (Set -> Set -> Set) -> Type where
--   Magmoid :
-- {-


-- Exercise 1
data Elem : a -> List a -> Type where
     Here : Elem x (x :: xs)
     There : Elem x xs -> Elem x (y :: xs)

-- Exercise 2
data Last : List a -> a -> Type where
     LastOne : Last [value] value
     LastCons : (prf : Last xs value) -> Last (x :: xs) value

lastNotNil : (value : a) -> Last [] x -> Void
lastNotNil _ LastOne impossible
lastNotNil _ (LastCons _) impossible

lastNotCons : (contra : Last (x :: xs) value -> Void) ->
              Last (y :: (x :: xs)) value -> Void
lastNotCons contra (LastCons prf) = contra prf

lastNotSingleton : (contra : (y = value) -> Void) -> Last [y] value -> Void
lastNotSingleton contra LastOne = contra Refl
lastNotSingleton _ (LastCons LastOne) impossible
lastNotSingleton _ (LastCons (LastCons _)) impossible

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No (lastNotNil value)
isLast (y :: []) value = case decEq y value of
                              (Yes Refl) => Yes LastOne
                              (No contra) => No (lastNotSingleton contra)
isLast (y :: (x :: xs)) value = case isLast (x :: xs) value of
                                     (Yes prf) => Yes (LastCons prf)
                                     (No contra) => No (lastNotCons contra)


{- 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

data Expr num
  = Val num
  | Add (Expr num) (Expr num)
  | Sub (Expr num) (Expr num)
  | Mul (Expr num) (Expr num)
  | Div (Expr num) (Expr num)
  | Abs (Expr num)

eval : (Abs num, Neg num, Integral num) => Expr num -> num
eval (Val x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x)   = abs (eval x)

data Expr' : Type -> Type where
  Val' : num -> Expr' num
  Add' : Num num => Expr' num -> Expr' num -> Expr' num
  Mul' : Num num => Expr' num -> Expr' num -> Expr' num
  Sub' : Neg neg => Expr' neg -> Expr' neg -> Expr' neg
  Div' : Integral int => Expr' int -> Expr' int -> Expr' int
  Abs' : Abs abs => Expr' abs -> Expr' abs

eval' : Expr' num -> num
eval' (Val' x) = x
eval' (Add' x y) = eval' x + eval' y
eval' (Mul' x y) = eval' x * eval' y
eval' (Sub' x y) = eval' x - eval' y
eval' (Div' x y) = eval' x `div` eval' y
eval' (Abs' x) = abs $ eval' x

Num ty => Num (Expr ty) where
  (+) = Add
  (*) = Mul
  fromInteger = Val . fromInteger

Neg ty => Neg (Expr ty) where
  negate x = 0 - x
  (-) = Sub

Abs ty => Abs (Expr ty) where
  abs = Abs

Show ty => Show (Expr ty) where
  show e = case e of
    (Val x) => show x
    (Add x y) => "(" ++ show x ++ " + " ++ show y ++ ")"
    (Sub x y) => "(" ++ show x ++ " - " ++ show y ++ ")"
    (Mul x y) => "(" ++ show x ++ " * " ++ show y ++ ")"
    (Div x y) => "(" ++ show x ++ " / " ++ show y ++ ")"
    (Abs x) => "|" ++ show x ++ "|"

(Eq ty, Integral ty, Neg ty, Abs ty) => Eq (Expr ty) where
  e1 == e2 = eval e1 == eval e2

(Integral ty, Neg ty, Abs ty) => Cast (Expr ty) ty where
  cast e = eval e

totalLen : List String -> Nat
totalLen xs = foldr (\str, len => length str + len) 0 xs

main : IO ()
main = do
  putStrLn "Expr"
  printLn $ eval $ the (Expr Integer) (Add (Val 6) (Mul (Val 3) (Val 12)))
  printLn $ eval $ the (Expr Integer) (6 + 3 * 12)
  printLn $ the (Expr Integer) (6 + 3 * 12)
  printLn $ eval' $ the (Expr' Integer) (Add' (Val' 6) (Mul' (Val' 3) (Val' 12)))
  printLn $ map (*2) [1,2,3,4]
  printLn $ foldr (+) 0 [1,2,3,4]
  printLn $ foldr (*) 1 [1,2,3,4]
  printLn $ totalLen ["One", "Two", "Three"]


data MyVect : (len: Nat) -> (elem: Type) -> Type where
  Nil  : MyVect 0 elem
  (::) : (e: elem) -> (tail: MyVect len elem) -> MyVect (S len) elem

Eq elem => Eq (MyVect n elem) where
  (==) Nil Nil = True
  (==) (head :: tail) (head' :: tail') = head == head' && tail == tail'

Foldable (MyVect n) where
  foldr func acc Nil = acc
  foldr func acc (e :: tail) =
    let
      foldedTail = foldr func acc tail
    in
      func e foldedTail

data EqNat: (num1: Nat) -> (num2: Nat) -> Type where
  Same: (num: Nat) -> EqNat num num

sameS : (k: Nat) -> (j: Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)
sameS j j (Same j) = Same (S j)

-- checkEqNat: (num1: Nat) -> (num2: Nat) -> Maybe (num1 = num2)
-- checkEqNat Z Z = Just Refl
-- checkEqNat Z (S k) = Nothing
-- checkEqNat (S k) Z = Nothing
-- checkEqNat (S k) (S j) =
--   case checkEqNat k j of
--     Nothing => Nothing
--     Just prf => Just (cong prf)

total zeroNotSuc : (0 = S k) -> Void
zeroNotSuc Refl impossible

total sucNotZero : (S k = 0) -> Void
sucNotZero Refl impossible

noRec : (contra : (k = j) -> Void) -> (S k = S j) -> Void
noRec contra Refl = contra Refl

checkEqNat: (num1: Nat) -> (num2: Nat) -> Dec (num1 = num2)
checkEqNat Z Z = Yes Refl
checkEqNat Z (S k) = No zeroNotSuc
checkEqNat (S k) Z = No sucNotZero
checkEqNat (S k) (S j) = case checkEqNat k j of
  Yes prf => Yes (cong prf)
  No contra => No (noRec contra)

exactLength: (len: Nat) -> (input: MyVect m a) -> Maybe (MyVect len a)
exactLength {m} len input =
  case decEq m len of
    Yes Refl  => Just input
    No contra => Nothing

total headUnequal: {xs: MyVect n a} -> {ys: MyVect n a} -> (contra: (x = y) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
headUnequal contra Refl = contra Refl

total tailUnequal: {xs: MyVect n a} -> {ys: MyVect n a} -> (contra: (xs = ys) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
tailUnequal contra Refl = contra Refl

DecEq a => DecEq (MyVect n a) where
  decEq [] [] = Yes Refl
  decEq (x :: xs) (y :: ys) = case decEq x y of
    Yes Refl => case decEq xs ys of
      Yes Refl  => Yes Refl
      No contra => No (tailUnequal contra)
    No contra => No (headUnequal contra)

example1: MyVect 4 Integer
example1 = 1 :: 2 :: 3 :: 4 :: Nil

example1': MyVect 4 Integer
example1' = 1 :: 2 :: 3 :: 4 :: Nil

example2: MyVect 3 Integer
example2 = 1 :: 2 :: 3 :: Nil

example3: MyVect 4 Integer
example3 = 4 :: 3 :: 2 :: 1 :: Nil

natEqual: (x: Nat) -> (y: Nat) -> Maybe(x = y)
natEqual Z Z = Just Refl
natEqual Z (S k) = Nothing
natEqual (S k) Z = Nothing
natEqual (S k) (S j) = case natEqual k j of
  Nothing => Nothing
  (Just prf) => Just (cong prf)


module BoehmBerarducci

%default total

NatQ : Type
NatQ = (A : Type) -> (A -> A) -> A -> A

unNatQ : {A : Type} -> (A -> A) -> A -> NatQ -> A
unNatQ f a q = q _ f a

succQ : NatQ -> NatQ
succQ q = \_, f, a => f (q _ f a)

zeroQ : NatQ
zeroQ = \_, f, a => a

fromNatQ : NatQ -> Nat
fromNatQ q = unNatQ S Z q

toNatQ : Nat -> NatQ
toNatQ (S n) = succQ (toNatQ n)
toNatQ Z     = zeroQ

iterated : Nat -> (a -> a) -> a -> a
iterated (S n) f a = f (iterated n f a)
iterated Z f a     = a

test_iterated : (n : Nat) -> iterated n S Z = n
test_iterated (S n) = rewrite test_iterated n in Refl
test_iterated Z     = Refl

test_fromNatQ : (n : Nat) -> fromNatQ (iterated n succQ zeroQ) = n
test_fromNatQ (S n) = rewrite test_fromNatQ n in Refl
test_fromNatQ Z     = Refl

test_toNatQ : (n : Nat) -> toNatQ n = iterated n succQ zeroQ
test_toNatQ (S n) = rewrite test_toNatQ n in Refl
test_toNatQ Z = Refl

ListQ : Type -> Type
ListQ A = (B : Type) -> (A -> B -> B) -> B -> B

unListQ : {A, B : Type} -> (A -> B -> B) -> B -> ListQ A -> B
unListQ f b q = q _ f b

consQ : {A : Type} -> A -> ListQ A -> ListQ A
consQ a q = \_, f, b => f a (q _ f b)

nilQ : {A : Type} -> ListQ A
nilQ = \_, f, b => b

fromListQ : {A : Type} -> ListQ A -> List A
fromListQ q = unListQ (::) [] q

toListQ : {A : Type} -> List A -> ListQ A
toListQ (a :: aa) = consQ a (toListQ aa)
toListQ []        = nilQ


> module Fraction.BasicOperations

> import Fraction.Fraction
> import PNat.PNat
> import PNat.Operations
> import Nat.Positive

> %default total
> %access public export

> ||| The numerator of a fraction
> num : Fraction -> Nat
> num = fst

> ||| The denominator of a fraction
> den : Fraction -> Nat
> den = toNat . snd

> ||| Every natural number is a fraction
> fromNat : Nat -> Fraction
> fromNat n = (n, Element (S Z) MkPositive)

> ||| Fraction addition
> plus : Fraction -> Fraction -> Fraction
> plus (n1, d1) (n2, d2) = (n1 * (toNat d2) + n2 * (toNat d1), d1 * d2)

> ||| Fraction multiplication
> mult : Fraction -> Fraction -> Fraction
> mult (n1, d1) (n2, d2) = (n1 * n2, d1 * d2)

> ||| Fraction upscaling
> upscale : Fraction -> PNat -> Fraction
> upscale (m, d) e = (m * (toNat e), d * e)


module Graphs1
import Data.Vect

%access public export

{-This program works only for simple undirected graphs. and whenever I use "am" it means adjacency matrix.
Please give a symmetric matrix for am. The important functions in this program are
EdgeisPath
ConnectedComponents
PathWithProof
AdjacentsAreConnected
-}
|||Checks whether 2 numbers are equal and returns nothing or a proof of equality
checkEqNat: (num1:Nat)->(num2:Nat)->Maybe (num1=num2)
checkEqNat Z Z = Just Refl
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Nothing => Nothing
                              (Just x) => Just (cong x)
|||Returns the i j element of an m by n matrix and nothing if ij is out of bounds.
Access : Vect m (Vect n Nat)->(i:Nat)->(j:Nat)->Maybe Nat
Access {n}{m} xs i j = case ((integerToFin  ((cast j)-1) n),(integerToFin  ((cast i)-1) m)) of
                         (Nothing, _) => Nothing
                         (_ ,Nothing) => Nothing
                         (Just x, Just y) => Just ((Vect.index x (Vect.index y xs)))

|||Returns the i j element of an n by n matrix with 0 if it is out of bounds
Accessnum:Vect n (Vect n Nat)->(i:Nat)->(j:Nat)-> Nat
Accessnum xs i j = case Access xs i j of
                    Nothing => 0
                    (Just x) => x
|||A type inhabited if only if vertices i and j are connected by an edge
data Edge :(am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)->Type where
    Thereisanedge :(am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)->(Accessnum am i j) =1 ->Edge am i j
|||A type inhabited iff vertices i and j are connected by a path
data Path : (am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)->Type where
  Self : (i:Nat)->Path am i i
  Adjacent : (Edge am i j) ->Path am i j
  Thereispath: (am:(Vect n (Vect n Nat)))-> (i:Nat)->(k:Nat) ->Path am i k->(Edge am j i)->Path am j k
|||Returns Nothing if there is no edge or a proof that Accessnum am i j =1
Isthereanedge: (am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)->Maybe ( (Accessnum am i j ) = 1)
Isthereanedge am i j = case Access am i j of
                            Nothing => Nothing
                            (Just x) => (case checkEqNat (Accessnum am i j ) 1 of
                                              Nothing => Nothing
                                              (Just y) => (Just y))
|||Returns a proof that 2 adjacent vertices are connected or nothing if they are not connected.
AdjacentsAreConnected:(am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)->Maybe (Path am i j)
AdjacentsAreConnected am i j = case Isthereanedge am i j of
                                    Nothing => Nothing
                                    (Just x) => Just (Adjacent (Thereisanedge am i j x))
|||Proves that adjacent vertices (ie vertices that have an edge between them are connected)
EdgeisPath :(am:(Vect n (Vect n Nat)))-> (Edge am i j)->Path am i j
EdgeisPath am (Thereisanedge am i j prf) = Adjacent (Thereisanedge am i j prf)

|||Checks whether a Natural number is in the list or not
isInList  : (i:Nat)->List Nat ->Bool
isInList i [] = False
isInList i (x :: xs) = case (x==i) of
                            False => isInList i xs
                            True => True
|||Updates an adjacency list if there is an edge between i and (S j) and calls the same function with j
adja :(am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)  ->List (s:Nat**Path am i s)->List (s:Nat**Path am i s)
adja am i Z xs = xs
adja am i (S k) xs = case AdjacentsAreConnected am i (S k) of
                      Nothing => adja am i k xs
                      (Just x) => adja am i k (((S k )**x)::xs)
|||Returns a list of adjacent vectors to i with a proof that they are connected
Adjacents :(am:(Vect n (Vect n Nat)))-> (i:Nat)->List (s:Nat**Path am i s)
Adjacents {n} am i = adja am i n []
Adjacentlist:(am:(Vect n (Vect n Nat)))-> (i:Nat)->List Nat
Adjacentlist am i = map fst (Adjacents am i)
|||Returns the list of elements in the first list, but not in the second
Complement: List Nat ->List Nat ->List Nat
Complement [] ys = []
Complement (x :: xs) ys = case isInList x ys of
                               False => x::(Complement xs ys)
                               True => Complement xs ys

|||Does Depth first search of i and returns the list of elements connected to i
Dfs :(am:(Vect n (Vect n Nat)))-> (i:Nat) ->List Nat->List Nat
Dfs am i xs = case Complement (Adjacentlist am i) xs of
                     []=>xs
                     (j::ys)=>Dfs am i (Dfs am j (j::xs))

|||A helper function for ConnectedComponents
Connectedcompos: (am:(Vect n (Vect n Nat)))->List Nat ->List (List Nat)->(List (List Nat))
Connectedcompos{n} am xs ys = case Complement [1..n] xs of
                                [] => ys
                                (x :: zs) => Connectedcompos am (xs++(Dfs am x [x])) ((Dfs am x [x])::ys)

|||Gives the connected components of a graph as a list of lists
ConnectedComponents :  (am:(Vect n (Vect n Nat)))->(List (List Nat))
ConnectedComponents am = Connectedcompos am [] []

|||Modified depth first search which searches for a path between i and k. When there is no path, it behaves just like a depth first search from i
Dfss :(am:(Vect n (Vect n Nat)))-> (i:Nat) ->(k:Nat)->(Found:Bool)->List Nat->List Nat->((List Nat,List Nat),Bool)
Dfss am i k True path visit = ((path,visit),True)
Dfss am i k False path visit = case Complement (Adjacentlist am i) visit of
                     []=>(([],visit),False)
                     (j::ys)=>(case (k==j) of
                       True =>(((k::path),(j::visit)),True)
                       False =>  let dps =(Dfss am j k False (j::path) (j::visit)) in (let pathn = (case (snd(dps)) of
                                                                                False => path
                                                                                True => (fst (fst (dps)))) in (Dfss am i k  (snd(dps)) pathn (snd (fst (dps))))))

||| Ruturns a path between 2 vertices and returns Nothing if there is no path.
FindPath :(am:(Vect n (Vect n Nat)))->(k:Nat)->(i:Nat)->Maybe (List Nat)
FindPath am k i = case (k==i) of
                  True => Just [i]
                  False =>   (case isInList k (Dfs am  i [i])  of
                     False => Nothing
                     True => Just (fst (fst (Dfss am i k False [i] [i]))))
|||Gives the proof that there is a path between i and k when the path is not just one vertex long
Proofcon2 :(am:(Vect n (Vect n Nat)))-> List Nat -> (i:Nat)->(k:Nat)-> Path am i k
Proofcon2 am [j,p] i k = case checkEqNat p k of
                           (Just Refl) => (case AdjacentsAreConnected am i k of
                                                (Just x) => x)
Proofcon2 am (x::y::z::xs) i k =case AdjacentsAreConnected am i y of
                                                           (Just (Adjacent x)) => (let loop = Proofcon2 am (y::z::xs) y k in
                                                                 Thereispath am y k loop x )

|||Gives proof for 1 vertex long paths and calls proofcon2 when there are at least 2 vertices in the path
Proofcon :(am:(Vect n (Vect n Nat)))-> List Nat -> (i:Nat)->(k:Nat)-> Path am i k
Proofcon am xs i k = case checkEqNat i k of
                          (Just Refl) => Self i
                          Nothing => Proofcon2 am xs i k
|||Gives a path with proof when there is a path between k and i and Nothing when there is no path.
PathWithProof :(am:(Vect n (Vect n Nat)))->(k:Nat)->(i:Nat)->Maybe((List Nat),Path am k i )
PathWithProof am k i = case FindPath am k i of
                        Nothing => Nothing
                        Just x => Just (x,Proofcon am x k i)


module Evens

% access public export

public export
data IsEven : Nat -> Type where
  ZEven : IsEven 0
  SSEven : (n: Nat) -> IsEven n -> IsEven (S (S n))

twoEven : IsEven 2
twoEven = SSEven 0 ZEven

fourEven : IsEven 4
fourEven = SSEven 2 twoEven

half : (n: Nat) -> IsEven n -> Nat
half Z ZEven = 0
half (S (S k)) (SSEven k x) = S (half k x)

double: Nat -> Nat
double Z = Z
double (S k) = S (S (double k))

doubleEven : (n: Nat) -> IsEven (double n)
doubleEven Z = ZEven
doubleEven (S k) = SSEven (double k) (doubleEven k)

halfDouble: Nat -> Nat
halfDouble n = half (double n) (doubleEven n)

oneOdd: IsEven 1 -> Void
oneOdd ZEven impossible
oneOdd (SSEven _ _) impossible

threeOdd : IsEven 3 -> Void
threeOdd (SSEven (S Z) ZEven) impossible
threeOdd (SSEven (S Z) (SSEven _ _)) impossible

nOrSnEven: (n: Nat) -> Either (IsEven n) (IsEven (S n))
nOrSnEven Z = Left ZEven
nOrSnEven (S k) = case (nOrSnEven k) of
                       (Left l) => Right (SSEven k l)
                       (Right r) => Left r

halfRoof: Nat -> Nat
halfRoof n = case (nOrSnEven n) of
                  (Left nEven) => half n nEven
                  (Right snEven) => half (S n) snEven

nSnNotBothEven: (n: Nat) -> (IsEven n) -> IsEven (S n) -> Void
nSnNotBothEven Z ZEven ZEven impossible
nSnNotBothEven Z ZEven (SSEven _ _) impossible
nSnNotBothEven (S (S k)) (SSEven k x) (SSEven (S k) y) = nSnNotBothEven k x y

notNandSnEven : (n: Nat) -> (IsEven n , IsEven (S n)) -> Void
notNandSnEven n (a, b) = nSnNotBothEven n a b

apNat : (f: Nat -> Nat) -> (n: Nat) -> (m: Nat) -> n = m -> f n = f m
apNat f m m Refl = Refl

byTwo : (n: Nat) -> IsEven n -> (k: Nat ** double k = n)
byTwo Z ZEven = (0 ** Refl)
byTwo (S (S k)) (SSEven k x) = step where
  step = case (byTwo k x) of
            (m ** pf) => ((S m) ** apNat (\l => S (S l)) (double m) k pf)

oneOddFamily : Nat -> Type
oneOddFamily Z = ()
oneOddFamily (S Z) = Void
oneOddFamily (S (S k)) = ()

oneOddProof : (n : Nat) -> IsEven n -> oneOddFamily n
oneOddProof Z ZEven = ()
oneOddProof (S (S k)) (SSEven k x) = ()

-- Examples

halfRoof3 : Nat
halfRoof3 = halfRoof 3 -- 2 : Nat

-- Equality added

thmAdd : (a: Nat) -> (b: Nat) -> (a = 0) -> (b = 0) -> (a + b = 0)
thmAdd Z Z Refl Refl = Refl

symmEq : (x : Type) -> (a: x) -> (b: x) -> (a = b) -> (b = a)
symmEq x b b Refl = Refl


import Data.Vect

word_lengths : Vect len String -> Vect len Nat
word_lengths [] = []
word_lengths (x :: xs) = length x :: word_lengths xs

-- insertion sort
insert : Ord elem =>
         (x : elem) -> (xs_sorted : Vect k elem) -> Vect (S k) elem
insert x [] = [x]
insert x (y :: xs) = case x < y of
                          False => y :: insert x xs
                          True => x :: y :: xs

ins_sort : Ord elem => Vect n elem -> Vect n elem
ins_sort [] = []
ins_sort (x :: xs) = let xs_sorted = ins_sort xs in
                         insert x xs_sorted

-- 3.2.4 excercises

my_length : List a -> Nat
my_length [] = 0
my_length (x :: xs) = 1 + (my_length xs)

||| length using type var
my_length_vect : Vect n a -> Nat
my_length_vect {n} xs = n

my_reverse : List a -> List a
my_reverse = foldl (flip (::)) []

mymap : (a -> b) -> List a -> List b
mymap f [] = []
mymap f (x :: xs) = f x :: mymap f xs

-- this one generated itself!!
mymapv : (a -> b) -> Vect n a -> Vect n b
mymapv f [] = []
mymapv f (x :: xs) = f x :: mymapv f xs

-- 3.3

create_empties : Vect n (Vect 0 elem)
create_empties = replicate _ []

transpose_helper : (x : Vect n elem) -> (xs_trans : Vect n (Vect k elem)) ->
                    Vect n (Vect (S k) elem)
transpose_helper [] [] = []
transpose_helper (x :: xs) (y :: ys) = (x :: y) :: transpose_helper xs ys
-- usage replaced by zipWith

transpose_mat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transpose_mat [] = create_empties
transpose_mat (x :: xs) = let xs_trans = transpose_mat xs in
                              zipWith (::) x xs_trans

addMatrix : Num a => Vect n (Vect m a) -> Vect n (Vect m a) ->
            Vect n (Vect m a)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = zipWith (+) x y :: addMatrix xs ys


> module Nat.LTProperties

> import Nat.BasicProperties
> import Nat.LTEProperties

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

|LT| is unique:

> ||| LT is unique
> uniqueLT : (p1 : LT m n) -> (p2 : LT m n) -> p1 = p2
> uniqueLT {m} {n} = uniqueLTE {m = S m} {n = n}
> %freeze uniqueLT

> |||
> uniqueLT' : m1 = m2 -> n1 = n2 -> (p1 : LT m1 n1) -> (p2 : LT m2 n2) -> p1 = p2
> uniqueLT' Refl Refl p1 p2 = uniqueLT p1 p2
> %freeze uniqueLT'

|LT| is decidable:

> ||| LT is decidable
> decLT : (m : Nat) -> (n : Nat) -> Dec (LT m n)
> decLT m n = decLTE (S m) n
> %freeze decLT

Properties of |LT| and successor:

> |||
> ltLemma1 : (m : Nat) -> (n : Nat) -> LT (S m) n -> LT m n
> ltLemma1 m n prf = lteLemma1 (S m) n prf
> %freeze ltLemma1

> ||| LT is contained in LTE
> ltInLTE : (m : Nat) -> (n : Nat) -> LT m n -> LTE m n
> ltInLTE = lteLemma1
> %freeze ltInLTE

> ||| Zero is smaller than any successor
> ltZS : (m : Nat) -> LT Z (S m)
> ltZS  Z    = LTESucc LTEZero
> ltZS (S m) = idSuccPreservesLTE (S Z) (S m) (ltZS m)
> %freeze ltZS

> ||| Zero is smaller than any successor
> ltZS' : {n : Nat} -> LT Z (S n)
> ltZS' {n = Z}   = LTESucc LTEZero
> ltZS' {n = S m} = idSuccPreservesLTE (S Z) (S m) ltZS'
> %freeze ltZS'

> ||| Any number is smaller than its successor
> ltIdS : (m : Nat) -> LT m (S m)
> ltIdS  Z    = LTESucc LTEZero
> ltIdS (S m) = LTESucc (ltIdS m)
> %freeze ltIdS

> ||| Any number which is not zero is greater than zero
> notZisgtZ : {n : Nat} -> Not (n = Z) -> LT Z n
> notZisgtZ {n = Z}   contra = void (contra Refl)
> notZisgtZ {n = S m} _      = ltZS m
> %freeze notZisgtZ

> ||| Any number which is greater than zero is not zero
> gtZisnotZ : {n : Nat} -> LT Z n -> Not (n = Z)
> gtZisnotZ {n = Z}   p = absurd p
> gtZisnotZ {n = S m} p = SIsNotZ
> %freeze gtZisnotZ

> ||| No number is less than zero
> notLTzero : {n : Nat} -> Not (LT n Z)
> notLTzero = succNotLTEzero
> %freeze notLTzero

> |||
> strengthenLT : (m : Nat) -> (n : Nat) -> LT m (S n) -> Not (m = n) -> LT m n
> strengthenLT  Z       n  _       zNEQn   = notZisgtZ (zNEQn . sym)
> strengthenLT (S m)  Z    smLTsz  _       = void (notLTzero (fromLteSucc smLTsz))
> strengthenLT (S m) (S n) smLTssn smNEQsn = LTESucc mLTn where
>   mLTsn : LT m (S n)
>   mLTsn = fromLteSucc smLTssn
>   mNEQn : Not (m = n)
>   mNEQn = predInjective m n smNEQsn
>   mLTn : LT m n
>   mLTn = strengthenLT m n mLTsn mNEQn
> %freeze strengthenLT

> {-

> ---}


||| Implementation of ordering relations for `Nat`ural numbers
module Data.Nat.Order

import Data.Nat
import Data.Fun
import Data.Rel
import Decidable.Decidable

%default total

public export
zeroNeverGreater : Not (LTE (S n) Z)
zeroNeverGreater LTEZero     impossible
zeroNeverGreater (LTESucc _) impossible

public export
zeroAlwaysSmaller : {n : Nat} -> LTE Z n
zeroAlwaysSmaller = LTEZero

public export
ltesuccinjective : {0 n, m : Nat} -> Not (LTE n m) -> Not (LTE (S n) (S m))
ltesuccinjective disprf (LTESucc nLTEm) = void (disprf nLTEm)
ltesuccinjective disprf LTEZero         impossible

-- Remove any time after release of 0.6.0
||| Deprecated. Use `Nat.isLTE`.
public export
decideLTE : (n : Nat) -> (m : Nat) -> Dec (LTE n m)
decideLTE = isLTE

public export
Decidable 2 [Nat,Nat] LTE where
  decide = decideLTE

public export
Decidable 2 [Nat,Nat] LT where
  decide m = decideLTE (S m)

public export
lte : (m : Nat) -> (n : Nat) -> Dec (LTE m n)
lte m n = decide {ts = [Nat,Nat]} {p = LTE} m n

public export
shift : (m : Nat) -> (n : Nat) -> LTE m n -> LTE (S m) (S n)
shift m n mLTEn = LTESucc mLTEn


module Toolkit.Data.List.Size

public export
data Size : List a -> Nat -> Type where
  Zero    : Size Nil Z
  PlusOne : Size       rest     k
         -> Size (e :: rest) (S k)

export
size' : (xs : List a) -> DPair Nat (Size xs)
size' [] = MkDPair Z Zero
size' (x :: xs) with (size' xs)
  size' (x :: xs) | (MkDPair k rest) = MkDPair (S k) (PlusOne rest)

export
size : (xs : List a) -> Size xs (length xs)
size [] = Zero
size (x :: xs) = PlusOne (size xs)

Uninhabited (Size Nil (S x)) where
  uninhabited Zero impossible
  uninhabited (PlusOne x) impossible

Uninhabited (Size (x::xs) Z) where
  uninhabited Zero impossible
  uninhabited (PlusOne x) impossible

export
hasSize : (xs : List a) -> (d : Nat) -> Dec (Size xs d)
hasSize xs d with (xs)
  hasSize xs 0 | [] = Yes Zero
  hasSize xs (S k) | [] = No absurd

  hasSize xs 0 | (x :: ys) = No absurd
  hasSize xs (S k) | (x :: ys) with (hasSize ys k)
    hasSize xs (S k) | (x :: ys) | (Yes prf) = Yes (PlusOne prf)
    hasSize xs (S k) | (x :: ys) | (No contra) = No (\(PlusOne y) => contra y)

-- [ EOF ]


module Part2.Sec6_2_1_adder

{-
Think of this type as type level function
second case maps AdderType to a function type
-}
AdderType : (numargs : Nat) -> Type
AdderType Z = Int
AdderType (S k) = (nextArg : Int) -> AdderType k

||| adder numargs acc nums...
||| adder 0 : Int -> Int
||| adder 1 : Int -> Int -> Int
||| adder 2 : Int -> Int -> Int -> Int
||| adder 2 : Int -> Int -> Int -> Int
adder : (numargs : Nat) -> (acc : Int) -> AdderType numargs
adder Z acc = acc
adder (S k) acc = \nextArg => adder k (nextArg + acc)


module MergeSort

data SplitList : List a -> Type where
     SplitNil : SplitList []
     SplitOne : SplitList [x]
     SplitPair : (lefts : List a) -> (rights : List a) -> SplitList (lefts ++ rights)

total
splitList : (l : List a) -> SplitList l
splitList inp = splitListHelp inp inp
  where
    splitListHelp : List a -> (l : List a) -> SplitList l
    splitListHelp _ [] = SplitNil
    splitListHelp _ [x] = SplitOne
    splitListHelp (_ :: _ :: counter) (i :: items) = case splitListHelp counter items of
                                                          SplitNil => SplitOne
                                                          SplitOne {x} => SplitPair [i] [x]
                                                          (SplitPair lefts rights) => SplitPair (i :: lefts) rights
    splitListHelp _ items = SplitPair [] items

mergeSort : Ord a => List a -> List a
mergeSort xs with (splitList xs)
  mergeSort [] | SplitNil = []
  mergeSort [x] | SplitOne = [x]
  mergeSort (lefts ++ rights) | (SplitPair lefts rights) = merge (mergeSort lefts) (mergeSort rights)


> module Nat.GCDProperties

> import Nat.GCD
> import Nat.GCDOperations
> import Nat.Divisor
> import Nat.DivisorOperations
> import Nat.DivisorProperties
> import Nat.LTProperties
> import Nat.OperationsProperties
> import Basic.Operations
> import Sigma.Sigma
> import Pairs.Operations

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

> |||
> gcdUnique : (d1 : Nat) -> (d2 : Nat) -> GCD d1 m n -> GCD d2 m n -> d1 = d2
> gcdUnique d1 d2 (MkGCD d1Dm d1Dn d1G) (MkGCD d2Dm d2Dn d2G) = s3 where
>   s1 : d1 `Divisor` d2
>   s1 = d2G d1 d1Dm d1Dn
>   s2 : d2 `Divisor` d1
>   s2 = d1G d2 d2Dm d2Dn
>   s3 : d1 = d2
>   s3 = divisorAntisymmetric d1 d2 s1 s2
> %freeze gcdUnique

> |||
> gcdCommutative : GCD d m n -> GCD d n m
> gcdCommutative (MkGCD dDm dDn dG) = (MkGCD dDn dDm (\ d' => \ n => \ m => dG d' m n))
> %freeze gcdCommutative

> ||| If |m| is positive, the greatest common divisor of |m| and |n| is positive
> gcdPreservesPositivity1 : Z `LT` m -> (dv : Sigma Nat (\ d => GCD d m n)) -> Z `LT` (getWitness dv)
> gcdPreservesPositivity1 {m} zLTm (MkSigma d prf) = multLTZeroLeftLTZero d q zLTdq where
>   dDm : d `Divisor` m
>   dDm = gcdDivisorFst prf
>   q : Nat
>   q = quotient m d dDm
>   zLTdq : Z `LT` (d * q)
>   zLTdq = replace {x = m}
>                   {y = d * q}
>                   {P = \ ZUZU => Z `LT` ZUZU}
>                   (sym (quotientLemma m d dDm)) zLTm
> %freeze gcdPreservesPositivity1

> ||| If |n| is positive, the greatest common divisor of |m| and |n| is positive
> gcdPreservesPositivity2 : Z `LT` n -> (dv : Sigma Nat (\ d => GCD d m n)) -> Z `LT` (getWitness dv)
> gcdPreservesPositivity2 {n} zLTn (MkSigma d prf) = multLTZeroLeftLTZero d q zLTdq where
>   dDn : d `Divisor` n
>   dDn = gcdDivisorSnd prf
>   q : Nat
>   q = quotient n d dDn
>   zLTdq : Z `LT` (d * q)
>   zLTdq = replace {x = n}
>                   {y = d * q}
>                   {P = \ ZUZU => Z `LT` ZUZU}
>                   (sym (quotientLemma n d dDn)) zLTn
> %freeze gcdPreservesPositivity2

> |||
> gcdLemma : (v : GCD (S d) m n) ->
>            d' `Divisor` (quotient m (S d) (gcdDivisorFst v)) ->
>            d' `Divisor` (quotient n (S d) (gcdDivisorSnd v)) ->
>            d' `Divisor` S Z
> gcdLemma {d} {d'} {m} {n} v d'DmoSd d'DnoSd = divisorOneLemma d d' Sdd'DSd where
>   SdDm    : (S d) `Divisor` m
>   SdDm    = gcdDivisorFst v
>   SdDn    : (S d) `Divisor` n
>   SdDn    = gcdDivisorSnd v
>   SdG     : (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` (S d)
>   SdG     = gcdDivisorGreatest v
>   Sdd'Dm  : (S d) * d' `Divisor` m
>   Sdd'Dm  = divisorTowerLemma (S d) d' m SdDm d'DmoSd
>   Sdd'Dn  : (S d) * d' `Divisor` n
>   Sdd'Dn  = divisorTowerLemma (S d) d' n SdDn d'DnoSd
>   Sdd'DSd : (S d) * d' `Divisor` (S d)
>   Sdd'DSd = SdG ((S d) * d') Sdd'Dm Sdd'Dn
> %freeze gcdLemma

> |||
> gcdLemma' : (v : GCD d m n) -> Not (d = Z) ->
>             d' `Divisor` (quotient m d (gcdDivisorFst v)) ->
>             d' `Divisor` (quotient n d (gcdDivisorSnd v)) ->
>             d' `Divisor` S Z
> gcdLemma' {d} {d'} {m} {n} v dNotZ d'DmoSd d'DnoSd = divisorOneLemma' d d' dNotZ Sdd'DSd where
>   SdDm    : d `Divisor` m
>   SdDm    = gcdDivisorFst v
>   SdDn    : d `Divisor` n
>   SdDn    = gcdDivisorSnd v
>   SdG     : (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d
>   SdG     = gcdDivisorGreatest v
>   Sdd'Dm  : d * d' `Divisor` m
>   Sdd'Dm  = divisorTowerLemma d d' m SdDm d'DmoSd
>   Sdd'Dn  : d * d' `Divisor` n
>   Sdd'Dn  = divisorTowerLemma d d' n SdDn d'DnoSd
>   Sdd'DSd : d * d' `Divisor` d
>   Sdd'DSd = SdG (d * d') Sdd'Dm Sdd'Dn
> %freeze gcdLemma'

> |||
> gcdLemma'' : (d : Nat) -> (m : Nat) -> (n : Nat) ->
>              (dDm : d `Divisor` m) -> (dDn : d `Divisor` n) ->
>              (v : GCD d m n) -> Z `LT` d ->
>              (d' : Nat) ->
>              d' `Divisor` (quotient m d dDm) ->
>              d' `Divisor` (quotient n d dDn) ->
>              d' `Divisor` S Z
> gcdLemma'' d m n dDm dDn v zLTd d' d'Dqmd d'Dqnd = divisorOneLemma'' d d' zLTd dd'Dd where
>   dG     : (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d
>   dG     = gcdDivisorGreatest v
>   dd'Dm  : d * d' `Divisor` m
>   dd'Dm  = divisorTowerLemma d d' m dDm d'Dqmd
>   dd'Dn  : d * d' `Divisor` n
>   dd'Dn  = divisorTowerLemma d d' n dDn d'Dqnd
>   dd'Dd  : d * d' `Divisor` d
>   dd'Dd  = dG (d * d') dd'Dm dd'Dn
> %freeze gcdLemma''

> ||| d GCD ((S a) * m) ((S a) * n) => d/(S a) GCD m n
> |||
> ||| The implementation is based on a proof by Tim Richter. We have to show
> |||
> |||   1) d/(S a) is a divisor of m
> |||   2) d/(S a) is a divisor of n
> |||   3) if d' is a divisor of m and n, then d' is a divisor of d/(S a)
> |||
> ||| We know from |quotientDivisorLemma| that
> |||
> |||   a|b, b|c, a|c => (b/a)|(c/a)
> |||
> ||| Thus, we can prove 1) and 2) by applying the lemma to
> |||
> |||   (S a)|d, d|((S a) * m), (S a)|((S a) * m)
> |||
> |||   and
> |||
> |||   (S a)|d, d|((S a) * n), (S a)|((S a) * n)
> |||
> ||| and using |quotientCancellationLemma| to reduce ((S a) * m)/(S a) and
> ||| ((S a) * n)/(S a) to m and n, respectively. Since d is the GCD of
> ||| (S a) * m and (S a) * n and (S a) is trivially a divisor of both, we
> ||| readily have (S a)|d. d|((S a) * m) and d|((S a) * m) also diretly follow
> ||| from d being the GCD of (S a) * m and (S a) * n.
> |||
> ||| In order to prove 3), we again apply |quotientDivisorLemma|, this time to
> |||
> |||   (S a)|((S a) * d'), ((S a) * d')|d, (S a)|d
> |||
> ||| We derive ((S a) * d')|d from the hypothesis d'|m, d'|n by pre-multiplying
> ||| by (S a) (and using |divisorMultLemma1|). This yields
> |||
> |||   ((S a) * d')|((S a) * m), ((S a) * d')|((S a) * n)
> |||
> ||| The result directly follows from d being the GCD of (S a) * m and (S a) * n.
> |||
> gcdDivisorLemma : (d : Nat) -> (m : Nat) -> (n : Nat) -> (a : Nat) ->
>                   GCD d ((S a) * m) ((S a) * n) ->
>                   Sigma ((S a) `Divisor` d) (\ saDd => GCD (quotient d (S a) saDd) m n)

> gcdDivisorLemma d m n a v = MkSigma saDd (MkGCD qDm qDn qG) where
>   dDsam   :  d `Divisor` ((S a) * m)
>   dDsam   =  gcdDivisorFst v
>   saDsam  :  S a `Divisor` ((S a) * m)
>   saDsam  =  Element m Refl
>   dDsan   :  d `Divisor` ((S a) * n)
>   dDsan   =  gcdDivisorSnd v
>   saDsan  :  S a `Divisor` ((S a) * n)
>   saDsan  =  Element n Refl
>   saDd    :  (S a) `Divisor` d
>   saDd    =  gcdDivisorGreatest {d = d} v (S a) saDsam saDsan

>   q       :  Nat
>   q       =  quotient d (S a) saDd
>   preqDm  :  q `Divisor` (quotient ((S a) * m) (S a) saDsam)
>   preqDm  =  quotientDivisorLemma a d ((S a) * m) saDd dDsam saDsam
>   qDm     :  q `Divisor` m
>   qDm     =  replace {x = quotient ((S a) * m) (S a) saDsam}
>                      {y = m}
>                      {P = \ ZUZU => q `Divisor` ZUZU}
>                      (quotientCancellationLemma m a saDsam) preqDm

>   preqDn  :  q `Divisor` (quotient ((S a) * n) (S a) saDsan)
>   preqDn  =  quotientDivisorLemma a d ((S a) * n) saDd dDsan saDsan
>   qDn     :  q `Divisor` n
>   qDn     =  replace {x = quotient ((S a) * n) (S a) saDsan}
>                      {y = n}
>                      {P = \ ZUZU => q `Divisor` ZUZU}
>                      (quotientCancellationLemma n a saDsan) preqDn

>   preqG   :  (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n ->
>              (quotient ((S a) * d') (S a) (Element d' Refl)) `Divisor` q
>   preqG d' d'Dm d'Dn  =  quotientDivisorLemma a ((S a) * d') d (Element d' Refl) sad'Dd saDd
>     where sad'Dsam  :  ((S a) * d') `Divisor` ((S a) * m)
>           sad'Dsam  =  divisorMultLemma1 (S a) (S a) (anyDivisorAny (S a)) m d' d'Dm
>           sad'Dsan  :  ((S a) * d') `Divisor` ((S a) * n)
>           sad'Dsan  =  divisorMultLemma1 (S a) (S a) (anyDivisorAny (S a)) n d' d'Dn
>           sad'Dd    :  ((S a) * d') `Divisor` d
>           sad'Dd    =  gcdDivisorGreatest {d = d} v ((S a) * d') sad'Dsam sad'Dsan
>
>   qG      :  (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` q
>   qG    d' d'Dm d'Dn     =  replace {x = quotient ((S a) * d') (S a) (Element d' Refl)}
>                                     {y = d'}
>                                     {P = \ ZUZU => ZUZU `Divisor` q}
>                                     (quotientCancellationLemma d' a (Element d' Refl)) (preqG d' d'Dm d'Dn)
> %freeze gcdDivisorLemma

> |||
> gcdScaleInvariant : (d : Nat) -> (m : Nat) -> (n : Nat) -> (d' : Nat) -> (a : Nat) ->
>                     GCD d m n -> GCD d' (a * m) (a * n) -> d' = a * d
> gcdScaleInvariant d m n d'  Z    v  v' = s6 where
>   s0   :  Z `Divisor` (Z * m)
>   s0   =  Element m Refl
>   s1   :  Z `Divisor` (Z * n)
>   s1   =  Element n Refl
>   s2   :  Z `Divisor` d'
>   s2   =  gcdDivisorGreatest {d = d'} v' Z s0 s1
>   s3   :  Nat
>   s3   =  getWitness s2
>   s4   :  Z * s3 = d'
>   s4   =  getProof s2
>   s5   :  d' = Z
>   s5   =  replace {x = Z * s3} {y = Z} {P = \ ZUZU => d' = ZUZU} (multZeroLeftZero s3) (sym s4)
>   s6   :  d' = Z * d
>   s6   =  replace {x = Z} {y = Z * d} {P = \ ZUZU => d' = ZUZU} (sym (multZeroLeftZero d)) s5
> gcdScaleInvariant d m n d' (S a) v  v' = s4 where
>   s0   :  (S a) `Divisor` d'
>   s0   =  getWitness (gcdDivisorLemma d' m n a v')
>   s1   :  GCD (quotient d' (S a) s0) m n
>   s1   =  getProof (gcdDivisorLemma d' m n a v')
>   s2   :  quotient d' (S a) s0 = d
>   s2   =  gcdUnique (quotient d' (S a) s0) d s1 v
>   s3   :  (S a) * (quotient d' (S a) s0) = (S a) * d
>   s3   =  multPreservesEq (S a) (S a) (quotient d' (S a) s0) d Refl s2
>   s4   :  d' = (S a) * d
>   s4   =  replace {x = (S a) * (quotient d' (S a) s0)}
>                   {y = d'}
>                   {P = \ ZUZU => ZUZU = (S a) * d}
>                   (quotientLemma d' (S a) s0) s3
> %freeze gcdScaleInvariant

> |||
> gcdScaleInvariantCoro1 : (m : Nat) -> (n : Nat) -> (d : Nat) -> (d1 : Nat) -> (d2 : Nat) ->
>                          (dDm : d `Divisor` m) -> (dDn : d `Divisor` n) ->
>                          GCD d1 (quotient m d dDm) (quotient n d dDn) -> GCD d2 m n -> d2 = d * d1
> gcdScaleInvariantCoro1 m n d d1 d2 dDm dDn v1 v2 =
>   gcdScaleInvariant d1 (quotient m d dDm) (quotient n d dDn) d2 d v1 v2' where
>     v2'  :  GCD d2 (d * (quotient m d dDm)) (d * (quotient n d dDn))
>     v2'  =  replace2 {a = Nat} {a1 = m} {a2 = d * (quotient m d dDm)}
>                      {b = Nat} {b1 = n} {b2 = d * (quotient n d dDn)}
>                      {P = \ ZAZA => \ ZUZU => GCD d2 ZAZA ZUZU}
>                      (sym (quotientLemma m d dDm)) (sym (quotientLemma n d dDn)) v2
> %freeze gcdScaleInvariantCoro1


module Ch04.SubTerm

import Ch03.Arith

||| Propositional type describing that one term is an direct subterm of another one.
data DirectSubTerm : Term -> Term -> Type where
  IsIfTerm : (x : Term) -> DirectSubTerm x (IfThenElse x y z)
  IsThenTerm : (y : Term) -> DirectSubTerm y (IfThenElse x y z)
  IsElseTerm : (z : Term) -> DirectSubTerm z (IfThenElse x y z)
  IsSuccSubTerm : (x : Term) -> DirectSubTerm x (Succ x)
  IsPredSubTerm : (x : Term) -> DirectSubTerm x (Pred x)

||| Propositional type describing that one term is a subterm of another one.
data SubTerm : Term -> Term -> Type where
  IsSubTermOfDirectSubTerm : SubTerm x y -> DirectSubTerm y z -> SubTerm x z
  IsEqual : SubTerm x x


-- My answer to the question in Slack https://functionalprogramming.slack.com/archives/C043A0KTY/p1613365432408100

import Syntax.PreorderReasoning

import Data.Nat

mult_plus_distr : (n, m, p : Nat) -> (n + m) * p = (n * p) + (m * p)
mult_plus_distr 0 m p = Refl
mult_plus_distr (S k) m p =
  let ih = mult_plus_distr k m p
  in rewrite ih in plusAssociative p (mult k p) (mult m p)

mult_assoc : (n, m, p : Nat) -> n * (m * p) = (n * m) * p
mult_assoc Z m p = Refl
mult_assoc (S k) m p = Calc $
  |~ (S k) * (m * p)
  ~~ (m * p) + k * (m * p) ... ( Refl )
  ~~ (m * p) + (k * m) * p ... ( cong ((m * p) +) $ mult_assoc k m p )
  ~~ (m + k * m) * p       ... ( sym $ mult_plus_distr m (k * m) p )


module Lib
import Types
import Data.List

public export
calculateDeltas : (Double,Double) -> (Double, Double) -> Double
calculateDeltas (t0, t1) (x, y) = t0 + t1 * x-y

avg : List Double -> Double
avg [] = 0.0
avg xs = (sum xs) / (cast (length xs))

getmult: List Double -> List Double -> List Double
getmult = zipWith (*)

public export
adjustDeltas : List Double -> List (Double,Double) -> List Double
adjustDeltas deltas examples =
  let xs = map fst examples in getmult deltas  xs

public export
newthetas : (Double, Double) -> Double -> List (Double, Double) ->  (Double, Double)
newthetas thetas alpha examples =
  let deltas = (map (calculateDeltas thetas) examples)
      adjusted = adjustDeltas deltas examples
      t0 = fst thetas
      t1 = snd thetas
      newt0 = t0 - alpha * avg deltas
      newt1 = t1 - alpha * avg adjusted
  in (newt0, newt1)

public export
linearRegression : (Double, Double) -> Double ->List (Double, Double) -> Int -> (Double, Double)
linearRegression coefficients alpha dataset iterations =
 case iterations == 0 of
      True => coefficients
      False => let thetas = newthetas coefficients alpha dataset in linearRegression thetas alpha dataset (iterations -1)


module Proofs.DiscreteOrderTheory

import Common.Util
import Specifications.DiscreteOrderedGroup
import Proofs.GroupCancelationLemmas
import Proofs.GroupTheory
import Proofs.GroupCancelMisc
import Proofs.OrderTheory
import Proofs.TranslationInvarianceTheory

%default total
%access export

infixl 8 #

lemmaOrder : {(#) : Binop s} ->
  PartiallyOrderedGroupSpec (#) e inv leq -> (a,b,c : s) ->
    a # (b # inv c) `leq` e -> a # b `leq` c
lemmaOrder spec a b c given = rewriteRelation leq o2 o3 o1 where
  o1 : a # (b # inv c) # c `leq` e # c
  o1 = translationInvariantR (invariantOrder spec) (a # (b # inv c)) e c given
  o2 : a # (b # inv c) # c = a # b
  o2 = groupCancelMisc1 (group spec) _ b c
  o3 : e # c = c
  o3 = neutralL (monoid (group spec)) c

strictOrderSeparates : {(+) : Binop s} -> {(<=) : Binrel s} ->
  DiscreteOrderedGroupSpec (+) zero neg (<=) unit -> (a,b : s) ->
    Not (a = b) -> a <= b -> unit + a <= b
strictOrderSeparates spec a b diff given = o4 where
  o1 : a + neg b <= zero
  o1 = groupInverseAndOrder (partiallyOrderedGroup spec) a b given
  o2 : a + neg b = zero -> a = b
  o2 = groupInverseAndEquality (group spec) a b
  o3 : unit + (a + neg b) <= zero
  o3 = discreteOrder spec (a + neg b) (contraposition o2 diff) o1
  o4 : unit + a <= b
  o4 = lemmaOrder (partiallyOrderedGroup spec) unit a b o3

public export
separate : Decidable [s,s] leq => {(+) : Binop s} ->
  DiscreteOrderedGroupSpec (+) zero neg leq unit ->
    (a,b : s) ->
    EitherErased (a `leq` b) (unit + b `leq` a)
separate spec a b =
  case decision {rel = leq} a b of
    Yes prf => Left prf
    No contra =>
      let (baLeq, diff) = orderContra (totalOrder spec) a b contra
          prf = strictOrderSeparates spec b a (diff . sym) baLeq
      in Right prf

public export
separateBis : Decidable [s,s] leq => {(+) : Binop s} ->
  DiscreteOrderedGroupSpec (+) zero neg leq unit ->
    (a,b : s) ->
    EitherErased (a `leq` neg unit + b) (b `leq` a)
separateBis spec a b =
  case separate spec b a of
    Left ba => Right ba
    Right ab => Left (orderInverseL (partiallyOrderedGroup spec) unit b a ab)


module Adithyau.Odds

import Evens

import Intro

data IsOdd : Nat -> Type where
	OneOdd : IsOdd (S Z)
	SSOdd : (k : Nat) -> IsOdd k -> IsOdd (S (S k))

threeOdd : IsOdd 3				{- 3 is odd -}
threeOdd = SSOdd (S Z) OneOdd

twoNotOdd : IsOdd 2 -> Void		{- 2 is not odd -}
twoNotOdd OneOdd impossible
twoNotOdd (SSOdd _ _) impossible

ifOddSEven : (n : Nat) -> (IsOdd n) -> (IsEven (S n))				{- if n is odd, S n is even -}
ifOddSEven (S Z) OneOdd = SSEven 0 ZEven
ifOddSEven (S (S k)) (SSOdd k x) = SSEven (S k) (ifOddSEven k x)

ifEvenSOdd : (n : Nat) -> (IsEven n) -> (IsOdd (S n))				{- if n is even, S n is odd -}
ifEvenSOdd Z ZEven = OneOdd
ifEvenSOdd (S (S k)) (SSEven k x) = SSOdd (S k) (ifEvenSOdd k x)

nOddorEven : (n : Nat) -> Either (IsEven n) (IsOdd n)				{- n is odd or even -}
nOddorEven Z = Left ZEven
nOddorEven (S k) = case (nOddorEven k) of
						(Left l) => Right (ifEvenSOdd k l)
						(Right r) => Left (ifOddSEven k r)

nNotOddandEven : (n : Nat) -> (IsEven n) -> (IsOdd n) -> Void		{- n is not both odd and even -}
nNotOddandEven Z ZEven _ impossible
nNotOddandEven Z (SSEven _ _) _ impossible
nNotOddandEven (S Z) _ OneOdd  impossible
nNotOddandEven (S Z) _ (SSOdd _ _) impossible
nNotOddandEven (S (S k)) ZEven _ impossible
nNotOddandEven (S (S k)) (SSEven k x) OneOdd impossible
nNotOddandEven (S (S k)) (SSEven k x) (SSOdd k y) = nNotOddandEven k x y

isEvenAdd : (n : Nat) -> (m : Nat) -> (IsOdd n) -> (IsOdd m) -> (IsEven (add n m))				{- if n and m are odd, add n m is even -}
isEvenAdd (S Z) k OneOdd x = ifOddSEven k x
isEvenAdd (S (S k)) l (SSOdd k proofk) proofl = SSEven (add k l) (isEvenAdd k l proofk proofl)

isDoubleS : (n : Nat) -> (IsOdd n) -> (m : Nat ** n = S (double m))					{- if n is odd, there exists an m such that n = S (double m) -}
isDoubleS (S Z) OneOdd = (Z ** Refl)
isDoubleS (S (S k)) (SSOdd k x) = step where
	step = case (isDoubleS k x) of
				(m ** pf) => ((S m) ** apNat (\l => S (S l)) k (S (double m)) pf)


module Evens

public export
data IsEven : Nat -> Type where
  ZEven : IsEven 0
  SSEven : (n: Nat) -> IsEven n -> IsEven (S (S n))

twoEven : IsEven 2
twoEven = SSEven 0 ZEven

fourEven : IsEven 4
fourEven = SSEven 2 twoEven

half : (n: Nat) -> IsEven n -> Nat
half Z ZEven = 0
half (S (S k)) (SSEven k x) = S (half k x)

public export
double: Nat -> Nat
double Z = Z
double (S k) = S (S (double k))

doubleEven : (n: Nat) -> IsEven (double n)
doubleEven Z = ZEven
doubleEven (S k) = SSEven (double k) (doubleEven k)

halfDouble: Nat -> Nat
halfDouble n = half (double n) (doubleEven n)

oneOdd: IsEven 1 -> Void
oneOdd ZEven impossible
oneOdd (SSEven _ _) impossible

threeOdd : IsEven 3 -> Void
threeOdd (SSEven (S Z) ZEven) impossible
threeOdd (SSEven (S Z) (SSEven _ _)) impossible

nOrSnEven: (n: Nat) -> Either (IsEven n) (IsEven (S n))
nOrSnEven Z = Left ZEven
nOrSnEven (S k) = case (nOrSnEven k) of
                       (Left l) => Right (SSEven k l)
                       (Right r) => Left r

halfRoof: Nat -> Nat
halfRoof n = case (nOrSnEven n) of
                  (Left nEven) => half n nEven
                  (Right snEven) => half (S n) snEven

nSnNotBothEven: (n: Nat) -> (IsEven n) -> IsEven (S n) -> Void
nSnNotBothEven Z ZEven ZEven impossible
nSnNotBothEven Z ZEven (SSEven _ _) impossible
nSnNotBothEven (S (S k)) (SSEven k x) (SSEven (S k) y) = nSnNotBothEven k x y

notNandSnEven : (n: Nat) -> (IsEven n , IsEven (S n)) -> Void
notNandSnEven n (a, b) = nSnNotBothEven n a b

apNat : (f: Nat -> Nat) -> (n: Nat) -> (m: Nat) -> n = m -> f n = f m
apNat f m m Refl = Refl

byTwo : (n: Nat) -> IsEven n -> (k: Nat ** double k = n)
byTwo Z ZEven = (0 ** Refl)
byTwo (S (S k)) (SSEven k x) = step where
  step = case (byTwo k x) of
            (m ** pf) => ((S m) ** apNat (\l => S (S l)) (double m) k pf)

oneOddFamily : Nat -> Type
oneOddFamily Z = ()
oneOddFamily (S Z) = Void
oneOddFamily (S (S k)) = ()

oneOddProof : (n : Nat) -> IsEven n -> oneOddFamily n
oneOddProof Z ZEven = ()
oneOddProof (S (S k)) (SSEven k x) = ()


-- 自己写的一个一个链表翻转程序和验证程序

{- 翻转函数 -}
myreverse : List a-> List a
myreverse [] = []
myreverse (x::xs) = myreverse xs ++ [x]

{- 引理1 -}
app_nil_r : (l:List a)->(l++[]=l)
app_nil_r [] = Refl
app_nil_r (x::xs) =
    let ind_xs = app_nil_r xs in
        rewrite ind_xs in Refl

{- 引理2：结合性 -}
app_assoc : (l1: List a) -> (l2 : List a) -> (l3:List a) -> ((l1++l2)++l3=l1++(l2++l3))
app_assoc [] l2 l3 = Refl
app_assoc (x::xs) l2 l3 =
    let ind_xs = app_assoc xs l2 l3 in
        rewrite ind_xs in Refl

{- 引理3：分配律 -}
app_distr : (l1:List a)->(l2:List a)->(myreverse (l1++l2)=myreverse l2++myreverse l1)
app_distr [] l2 =
    rewrite app_nil_r (myreverse l2) in Refl
app_distr (x::xs) l2 =
    rewrite app_distr xs l2 in
        rewrite app_assoc (myreverse l2) (myreverse xs) [x] in Refl

{- 定理：链表翻转的函数的逆元是其自身 -}
myreverseSym : (l:List a)->(l=myreverse (myreverse l))
myreverseSym [] = Refl
myreverseSym (x::xs) =
    let ind_xs = myreverseSym xs in
        rewrite app_distr (myreverse xs) [x] in
            rewrite ind_xs in Refl


module Main

import Data.Vect

allLengths : List String -> List Nat
allLengths [] = []
allLengths (w :: ws) = length w :: allLengths ws

xor : Bool -> Bool -> Bool
xor False y = y
xor True y = not y

isEven0 : Nat -> Bool
isEven0 Z = True
isEven0 (S k) = not (isEven0 k)

mutual
  isEven : Nat -> Bool
  isEven Z = True
  isEven (S k) = isOdd k

  isOdd : Nat -> Bool
  isOdd Z = False
  isOdd (S k) = isEven k

fourInts : Vect 4 Int
fourInts = [0,1,2,3]

sixInts : Vect 6 Int
sixInts = [4,5,6,7,8,9]

tenInts : Vect 10 Int
tenInts = fourInts ++ sixInts

--total
allLengths1 : Vect l String -> Vect l Nat
allLengths1 [] = []
allLengths1 (w :: ws) = length w :: allLengths1 ws -- length w :: allLengths1 ws

insert  : Ord elem
       => (x : elem) -> (xsSorted : Vect len elem) -> Vect (S len) elem
insert x [] = [x]
insert x (y :: xs) = case x < y of
  False => y :: insert x xs
  True => x :: y :: xs

insSort : Ord elem => Vect n elem -> Vect n elem
insSort [] = []
insSort (x :: xs) =
  let xsSorted = insSort xs
  in (insert x xsSorted)

addVector : Num num => Vect n num -> Vect n num -> Vect n num
addVector [] [] = []
addVector (x :: xs) (y :: ys) = x + y :: addVector xs ys

addMatrix
  : Num n
  => Vect rows (Vect cols n)
  -> Vect rows (Vect cols n)
  -> Vect rows (Vect cols n)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = addVector x y :: addMatrix xs ys

createEmpties : Num num => Vect m (Vect 0 num)
createEmpties {m} = replicate m []

transposeHelper
  : Num num
  => (x : Vect n num)
  -> (xsTrans : Vect n (Vect len num))
  -> Vect n (Vect (S len) num)
transposeHelper [] [] = []
transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys

transposeMat
  : Num num
  => Vect m (Vect n num)
  -> Vect n (Vect m num)
transposeMat [] = createEmpties
transposeMat (x :: xs) =
  let xsTrans = transposeMat xs
  in (transposeHelper x xsTrans)

{-
mulMatrix
  : Num num
  => Vect n (Vect m num)
  -> Vect m (Vect p num)
  -> Vect n (Vect p num)
-}

main : IO ()
main = do
  putStrLn $ show $ allLengths $ words "Hello World! This is nice. I am being an Idris dev."
  putStrLn $ show $ isEven0 100000
  putStrLn $ show $ isEven 100000
  putStrLn $ show $ tenInts
  putStrLn $ show $ insSort [1,8,9,7,5,6,3,2]
  putStrLn $ show $ addMatrix [[1,1], [2,2]] [[2,2], [1,1]]
  putStrLn $ show $ transposeMat [[1,2,3], [4,5,6]]


module Main
import Data.SnocList

|||Abstract Syntax Tree for Integer with addition, subtraction and multiplication
data ASTExpr
    = EIntLit Int
    | EAddition ASTExpr ASTExpr
    | ESubtraction ASTExpr ASTExpr
    | EMultiplication ASTExpr ASTExpr

|||Usng the Num interface to define basic numerical arithmetic
Num (ASTExpr) where
    (+) = EAddition
    (*) = EMultiplication
    fromInteger = EIntLit . fromInteger

|||Using the Neg interface to define operations on numbers which can be negative.
Neg (ASTExpr) where
    negate x = 0 - x
    (-) = ESubtraction

|||Instruction syntax
data Instruction = Push Int | Add | Sub | Mult

|||Compile expression to a list of instruction
total
compile : ASTExpr -> List Instruction
compile (EIntLit a) =  [Push a]
compile (EAddition a b) = compile a ++ compile b ++ [Add]
compile (ESubtraction a b) = compile a ++ compile b ++ [Sub]
compile (EMultiplication a b) = compile a ++ compile b ++ [Mult]

|||Writing the instructions to a file for the stack machine to execute
total
print : Instruction -> String
print (Push a) = "Push " ++ show a
print Add = "Add"
print Sub = "Sub"
print Mult = "Mult"

|||Helper function for printList (tail recursive and linear time by using stringMap)
total
stringMap : (a -> String) -> List a -> String
stringMap f = go Lin
  where go : SnocList String -> List a -> String
        go sx []         = concat (sx <>> Nil)
        go sx (x :: Nil) = go (sx :< f x) Nil
        go sx (x :: xs)  = go (sx :< f x :< "\n") xs

|||Writing the List instructions to a file for the stack machine to execute
total
printList : List Instruction -> String
printList = stringMap print

--Taking a machine configuration to the next one by executing a single step of computations
total
runInstruction : List Int -> Instruction -> Maybe (List Int)
runInstruction xs (Push a) = Just (a :: xs)
runInstruction (x :: y :: xs) Add = Just ((x + y) :: xs)
runInstruction (x :: y :: xs) Sub = Just ((y - x) :: xs)
runInstruction (x :: y :: xs) Mult = Just ((x * y) :: xs)
runInstruction _ _ = Nothing

|||Taking a machine configuration to the next one by executing multiple step of computations
total
runInstructions: List Instruction -> List Int -> Maybe (List Int)
runInstructions xs ys = foldlM runInstruction ys xs

|||Evaluate Abstract Syntax Tree and return value
total
evaluate : ASTExpr -> Int
evaluate (EIntLit a) = a
evaluate (EAddition a b) = evaluate a + evaluate b
evaluate (ESubtraction a b) = evaluate a - evaluate b
evaluate (EMultiplication a b) = evaluate a * evaluate b

|||Universal statement linking the evaluation path via compile followed by RunInstructions
total
runAll: (e : ASTExpr) -> Maybe (List Int)
runAll e = runInstructions(compile(e)) []

|||Universal statement linking the evaluation path via evaluate
total
runAll2: (e : ASTExpr) -> Maybe (List Int)
runAll2 e = Just([evaluate(e)])

-- Testing all functions invidually and against each other

--runInstruction
test_runInstruction_add : runInstruction [1, 2] Add = Just [3]
test_runInstruction_add = Refl

test_runInstruction_sub : runInstruction [2, 1] Sub = Just [-1]
test_runInstruction_sub = Refl

test_runInstruction_mult : runInstruction [10, 2] Mult = Just [20]
test_runInstruction_mult = Refl

--runInstructions
test_runInstructions_add : runInstructions [Push 1, Push 2, Add] [] = Just [3]
test_runInstructions_add = Refl

test_runInstructions_sub : runInstructions [Push 1, Push 2, Sub] [] = Just [-1]
test_runInstructions_sub = Refl

test_runInstructions_mult : runInstructions [Push 10, Push 2, Mult] [] = Just [20]
test_runInstructions_mult = Refl

--runAll
test_runAll_add : runAll (EAddition (EIntLit 2) (EIntLit 3))  = Just [5]
test_runAll_add = Refl

test_runAll_sub : runAll (ESubtraction (EIntLit 2) (EIntLit 3))  = Just [-1]
test_runAll_sub = Refl

test_runAll_mul : runAll (EMultiplication (EIntLit 10) (EIntLit 2))  = Just [20]
test_runAll_mul = Refl

--runAll2
test_runAll2_add : runAll2 (EAddition (EIntLit 2) (EIntLit 3))  = Just [5]
test_runAll2_add = Refl

test_runAll2_sub : runAll2 (ESubtraction (EIntLit 2) (EIntLit 3))  = Just [-1]
test_runAll2_sub = Refl

test_runAll2_mul : runAll2 (EMultiplication (EIntLit 10) (EIntLit 2))  = Just [20]
test_runAll2_mul = Refl

--equality between runAll and runAll2
test_both_RunAlls_add : runAll (EAddition (EIntLit 2) (EIntLit 3)) = runAll2 (EAddition (EIntLit 2) (EIntLit 3))
test_both_RunAlls_add = Refl

test_both_RunAlls_sub : runAll (ESubtraction (EIntLit 2) (EIntLit 3)) = runAll2 (ESubtraction (EIntLit 2) (EIntLit 3))
test_both_RunAlls_sub = Refl

test_both_RunAlls_mul : runAll (EMultiplication (EIntLit 10) (EIntLit 2)) = runAll2 (EMultiplication (EIntLit 10) (EIntLit 2))
test_both_RunAlls_mul = Refl

-- Testing the two evaluation paths
test3_allFunc_add : runInstructions (compile (EAddition (EIntLit 2) (EIntLit 3))) [] === Just [evaluate (EAddition (EIntLit 2) (EIntLit 3))]
test3_allFunc_add = Refl

test3_allFunc_sub : runInstructions (compile (ESubtraction (EIntLit 2) (EIntLit 3))) [] === Just [evaluate (ESubtraction (EIntLit 2) (EIntLit 3))]
test3_allFunc_sub = Refl

test3_allFunc_mul : runInstructions (compile (EMultiplication (EIntLit 10) (EIntLit 2))) [] === Just [evaluate (EMultiplication (EIntLit 10) (EIntLit 2))]
test3_allFunc_mul = Refl

main : IO ()
main = ?hole


-- This code is a copy of gist:
-- https://gist.github.com/david-christiansen/3660d5d45e9287c25a5e

module FizzBuzzC

%default total

-- Dependently typed FizzBuzz, constructively

-- A number is fizzy if it is evenly divisible by 3
data Fizzy : Nat -> Type where
  ZeroFizzy : Fizzy 0
  Fizz : Fizzy n -> Fizzy (3 + n)

-- Fizzy is a correct specification of divisibility by 3 - that is, if n is
-- fizzy then there exists some k such that n = 3*k.
fizzyCorrect : (n : Nat) -> Fizzy n -> (k : Nat ** n = 3 * k)
fizzyCorrect Z ZeroFizzy = (Z ** Refl)
fizzyCorrect (S (S (S k))) (Fizz x) =
  let (k' ** ih) = fizzyCorrect k x
  in (S k' ** ?fizzyIsAOK)

-- Basic fizziness lemmas
oneNotFizzy : Not (Fizzy 1)
oneNotFizzy (Fizz f) impossible

twoNotFizzy : Not (Fizzy 2)
twoNotFizzy (Fizz f) impossible

fizzyUp : Not (Fizzy n) -> Not (Fizzy (3 + n))
fizzyUp nope ZeroFizzy impossible
fizzyUp nope (Fizz f) = nope f

-- Fizziness is decidable
decFizzy : (n : Nat) -> Dec (Fizzy n)
decFizzy Z = Yes ZeroFizzy
decFizzy (S Z) = No oneNotFizzy
decFizzy (S (S Z)) = No twoNotFizzy
decFizzy (S (S (S k))) with (decFizzy k)
  decFizzy (S (S (S k))) | (Yes prf) = Yes (Fizz prf)
  decFizzy (S (S (S k))) | (No contra) = No $ fizzyUp contra

-- A number is buzzy if it is evenly divisible by 5
data Buzzy : Nat -> Type where
  ZeroBuzzy : Buzzy 0
  Buzz : Buzzy n -> Buzzy (5 + n)

-- Correctness of buzziness spec elided due to verbosity

oneNotBuzzy : Not (Buzzy 1)
oneNotBuzzy (Buzz b) impossible

twoNotBuzzy : Not (Buzzy 2)
twoNotBuzzy (Buzz b) impossible

threeNotBuzzy : Not (Buzzy 3)
threeNotBuzzy (Buzz b) impossible

fourNotBuzzy : Not (Buzzy 4)
fourNotBuzzy (Buzz b) impossible

buzzOff : Not (Buzzy n) -> Not (Buzzy (5 + n))
buzzOff nope ZeroBuzzy impossible
buzzOff nope (Buzz b) = nope b

decBuzzy : (n : Nat) -> Dec (Buzzy n)
decBuzzy Z = Yes ZeroBuzzy
decBuzzy (S Z) = No oneNotBuzzy
decBuzzy (S (S Z)) = No twoNotBuzzy
decBuzzy (S (S (S Z))) = No threeNotBuzzy
decBuzzy (S (S (S (S Z)))) = No fourNotBuzzy
decBuzzy (S (S (S (S (S k))))) with (decBuzzy k)
  decBuzzy (S (S (S (S (S k))))) | (Yes prf) = Yes (Buzz prf)
  decBuzzy (S (S (S (S (S k))))) | (No way) = No (buzzOff way)

-- A version of Dec that tracks two properties - DoubleDec A B is isomorphic
-- to (Dec A, Dec B). This is just for readability.
data DoubleDec : Type -> Type -> Type where
  Neither : Not a -> Not b -> DoubleDec a b
  First : a -> Not b -> DoubleDec a b
  Second : Not a -> b -> DoubleDec a b
  Both : a -> b -> DoubleDec a b

decFizzBuzz : (n : Nat) -> DoubleDec (Fizzy n) (Buzzy n)
decFizzBuzz n with (decFizzy n, decBuzzy n)
  decFizzBuzz n | (Yes f, Yes b) = Both f b
  decFizzBuzz n | (No nf, Yes b) = Second nf b
  decFizzBuzz n | (Yes f, No nb) = First f nb
  decFizzBuzz n | (No nf, No nb) = Neither nf nb

-- Let's show some fizzing and buzzing. Start with all the nats:
nats : Stream Nat
nats = iterate S Z

-- and the fizzed and buzzed nats
fizzBuzz : Stream (n : Nat ** DoubleDec (Fizzy n) (Buzzy n))
fizzBuzz = map (\n => (n ** (decFizzBuzz n))) (tail nats)

instance Show (n : Nat ** DoubleDec (Fizzy n) (Buzzy n)) where
  show (x ** Neither _ _) = show x
  show (x ** First _ _)   = "Fizz"
  show (x ** Second _ _)  = "Buzz"
  show (x ** Both _ _)    = "FizzBuzz"

-- Take the first 100 numbers' FizzBuzzes, then print them to the screen.
namespace Main
  main : IO ()
  main = sequence_ . map (putStrLn . show) . take 100 $ fizzBuzz

---------- Proofs ----------

FizzBuzzC.fizzyIsAOK = proof
  compute
  intros
  rewrite plusSuccRightSucc k' (plus k' 0)
  rewrite plusSuccRightSucc k' (S (plus k' (plus k' 0)))
  rewrite plusSuccRightSucc k' (plus k' (plus k' 0))
  rewrite ih
  trivial


 module Lecture.GCD

switchLTE : (n: Nat) -> (m: Nat) -> (contra : (LTE n m) -> Void) -> LTE m n
switchLTE Z m contra = void (contra (LTEZero))
switchLTE (S k) Z contra = LTEZero
switchLTE (S k) (S j) contra =
  LTESucc (switchLTE k j previousContra) where
    previousContra = \evidence : (LTE k j) => contra (LTESucc evidence)

EuclidIndAux_rhs_2 : (x : LTE left right) -> Nat
EuclidIndAux_rhs_2 x = ?EuclidIndAux_rhs_2_rhs

gcdAux: (n: Nat) -> (m: Nat) -> (LTE m n) -> Nat
gcdAux n Z LTEZero = n
gcdAux (S right) (S left) (LTESucc x) = EuclidIndAux_rhs_2 x

gcd : Nat -> Nat -> Nat
gcd k j = case isLTE j k of
               (Yes prf) => gcdAux k j prf
               (No contra) => gcdAux j k (switchLTE j k contra)


||| Implementation  of ordering relations for `Fin`ite numbers
module Data.Fin.Order

import Data.Fin
import Data.Fun
import Data.Rel
import Data.Nat
import Data.Nat.Order
import Decidable.Decidable
import Decidable.Order

using (k : Nat)
  data FinLTE : Fin k -> Fin k -> Type where
    FromNatPrf : {m : Fin k} -> {n : Fin k} -> LTE (finToNat m) (finToNat n) -> FinLTE m n

  implementation Preorder (Fin k) FinLTE where
    transitive m n o (FromNatPrf p1) (FromNatPrf p2) =
      FromNatPrf (LTEIsTransitive (finToNat m) (finToNat n) (finToNat o) p1 p2)
    reflexive n = FromNatPrf (LTEIsReflexive (finToNat n))

  implementation Poset (Fin k) FinLTE where
    antisymmetric m n (FromNatPrf p1) (FromNatPrf p2) =
      finToNatInjective m n (LTEIsAntisymmetric (finToNat m) (finToNat n) p1 p2)

  implementation Decidable [Fin k, Fin k] FinLTE where
    decide m n with (decideLTE (finToNat m) (finToNat n))
      decide m n | Yes prf    = Yes (FromNatPrf prf)
      decide m n | No  disprf = No (\ (FromNatPrf prf) => disprf prf)

  implementation Ordered (Fin k) FinLTE where
    order m n =
      either (Left . FromNatPrf)
             (Right . FromNatPrf)
             (order (finToNat m) (finToNat n))


module Edsl
import Data.Vect
import Data.Fin

data Ty = TyInt | TyBool | TyFun Ty Ty
interpTy : Ty -> Type
interpTy TyInt       = Int
interpTy TyBool      = Bool
interpTy (TyFun a t) = interpTy a -> interpTy t

using (G:Vect n Ty)
  data HasType : Fin n -> Vect n Ty -> Ty -> Type where
    Stop : HasType FZ (t :: G) t
    Pop  : HasType k G t -> HasType (FS k) (u :: G) t

  data Expr : Vect n Ty -> Ty -> Type where
    Var : HasType i G t -> Expr G t
    Val : (x : Int) -> Expr G TyInt
    Lam : Expr (a :: G) t -> Expr G (TyFun a t)
    App : Expr G (TyFun a t) -> Expr G a -> Expr G t
    Op  : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> Expr G c
    If  : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a

  data Env : Vect n Ty -> Type where
    Nil  : Env Nil
    (::) : interpTy a -> Env G -> Env (a :: G)

  interp : Env G -> Expr G t -> interpTy t
  interp env (Var i)     =  ?sdf2
  interp env (Val x)     = x
  interp env (Lam body)  = \x => interp (x :: env) body
  interp env (App f s)   = (interp env f) (interp env s)
  interp env (Op op x y) = op (interp env x) (interp env y)
  interp env (If x t e)  = if interp env x then interp env t else interp env e


import Data.Vect

total add_vec : Num t =>
          (x : Vect cols t) ->
          (y : Vect cols t) ->
          Vect cols t
add_vec [] [] = []
add_vec (x :: xs) (y :: ys) = (x + y) :: add_vec xs ys

total add : Num t =>
      Vect rows ( Vect cols t ) ->
      Vect rows ( Vect cols t ) ->
      Vect rows ( Vect cols t )
add [] [] = []
add (x :: xs) (y :: ys) = add_vec x y :: add xs ys

total createEmpties : Vect n (Vect 0 t)
createEmpties = replicate _ []

total transposeHelper : (x : Vect n elem) -> (xsTrans : Vect n (Vect k elem)) -> Vect n (Vect (S k) elem)
transposeHelper [] [] = []
transposeHelper (x :: ys) (y :: xs) = (x :: y) :: transposeHelper ys xs

total transpose' : Vect m (Vect n elem) -> Vect n (Vect m elem)
transpose' [] = createEmpties
transpose' (x :: xs) = let xsTrans = transpose' xs in
                          transposeHelper x xsTrans


> module Unique.Predicates -- from an idea by Tim Richter

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

> Unique : Type -> Type
> Unique t = (p : t) -> (q : t) -> p = q

> Unique0 : Type -> Type
> Unique0 = Unique

> Unique1 : {A : Type} -> (A -> Type) -> Type
> Unique1 {A} P = (a : A) -> Unique0 (P a)

> UniqueEq0 : Type -> Type
> UniqueEq0 A = (a1 : A) -> (a2 : A) -> Unique (a1 = a2)

> UniqueEq1 : {A : Type} -> (P : A -> Type) -> Type
> UniqueEq1 {A} P = (a : A) -> UniqueEq0 (P a)

> {- Maybe implement via a type class ?

> class Unique t where
>   unique : (p : t) -> (q : t) -> p = q

> -}


module Chapter3

import Data.Bool
import Data.InSet
import Data.Lawful.Eqv
import Data.List
import Data.Nat
import Data.So

import Syntax.WithProof

%default total

-- Exercise 3.1

public export
data Tree a = Tip
            | Node (Tree a) a (Tree a)

-- Telling once that here we're using the `Eq`-based equality for sets.
export %hint %inline
UsedEquality : Eqv a => Equality a
UsedEquality = StandardEq

public export
set : Eqv a => Tree a -> InSet a
set Tip          = []
set (Node l x r) = [x] + set l + set r

public export
all_satisfy : (a -> Bool) -> Tree a -> Bool
all_satisfy _ Tip          = True
all_satisfy p (Node l x r) = p x && all_satisfy p l && all_satisfy p r

public export
ord : Ord a => Tree a -> Bool
ord Tip = True
ord (Node l x r) = ord l && ord r && all_satisfy (<= x) l && all_satisfy (>= x) r

public export
ins : Ord a => a -> Tree a -> Tree a
ins n Tip = Node Tip n Tip
ins n t@(Node l x r) with (x == n)
  ins n t@(Node _ _ _) | True = t
  ins n t@(Node l x r) | False with (x < n)
    ins n t@(Node l x r) | False | True  = Node (ins n l) x r
    ins n t@(Node l x r) | False | False = Node l x (ins n r)

  -- Such verbose with-matching is done because else Idris suspects non-totality somewhy.

export
ins_adds : (Ord a, Eqv a) => (n : a) -> (t : Tree a) -> set (ins n t) == [n] + set t
ins_adds n Tip p = let u = union_empty_neutral ([n] + []) p in
                   rewrite u in -- what's the f**k? why should I do this?
                   rewrite union_empty_neutral [n] p in
                   Refl
ins_adds n (Node l x r) p with (@@(x =?= n))
  ins_adds n (Node l x r) p | (True ** prf) = ?ins_adds_rhs_1
  ins_adds n (Node l x r) p | (False ** prf) = ?ins_adds_rhs_2

split_and : {a, b : Bool} -> a && b = True -> (a = True, b = True)
split_and {a=True} {b=True} Refl = (Refl, Refl)

export
ins_preserves_ord : Ord a => (i : a) -> (t : Tree a) -> ord t = True -> ord (ins i t) = True
ins_preserves_ord i Tip prf = prf
ins_preserves_ord i (Node l x r) prf with (x == i)
  ins_preserves_ord i (Node l x r) prf | True = prf
  ins_preserves_ord i (Node l x r) prf | False with (x < i)
    ins_preserves_ord i (Node l x r) prf | False | True =
                                                          let v = ins_preserves_ord i l (fst $ split_and prf) in
                                                          let u = fst $ split_and $ snd $ split_and prf in
                                                          ?ins_preserves_ord_rhs_3
    ins_preserves_ord i (Node l x r) prf | False | False = ?ins_preserves_ord_rhs_4

-- Examples from section 3.5.1

public export
data Ev : Nat -> Type where
  Ev0  : Ev 0
  EvSS : Ev n -> Ev (S $ S n)

export
ev4 : Ev 4
ev4 = EvSS (EvSS Ev0)

public export
evn : Nat -> Bool
evn Z         = True
evn (S Z)     = False
evn (S (S n)) = evn n

export
ev_thus_evn_true : (n : Nat) -> Ev n -> evn n = True
ev_thus_evn_true 0         Ev0      = Refl
ev_thus_evn_true (S (S n)) (EvSS x) = ev_thus_evn_true n x

export
evn_true_thus_ev : (n : Nat) -> evn n = True -> Ev n
evn_true_thus_ev 0         _   = Ev0
evn_true_thus_ev (S (S n)) prf = EvSS $ evn_true_thus_ev n prf

export
ev_minus : (m : Nat) -> Ev m -> Ev (m `minus` 2)
ev_minus Z         Ev0      = Ev0
ev_minus (S (S n)) (EvSS x) = rewrite minusZeroRight n in x

export
not_ev_thus_evn_false : (n : Nat) -> Not $ Ev n -> evn n = False
not_ev_thus_evn_false 0         f = absurd $ f Ev0
not_ev_thus_evn_false (S 0)     _ = Refl
not_ev_thus_evn_false (S (S k)) f = not_ev_thus_evn_false k $ f . EvSS

export
evn_false_thus_not_ev : (n : Nat) -> evn n = False -> Not $ Ev n
evn_false_thus_not_ev (S (S k)) prf (EvSS x) = evn_false_thus_not_ev k prf x

-- Example from section 3.5.2

public export
data Star : (a -> a -> Type) -> a -> a -> Type where
  Refl : Star r x x
  Step : {0 r : a -> a -> Type} -> r x y -> Star r y z -> Star r x z

export
star_trans : Star r x y -> Star r y z -> Star r x z
star_trans Refl       y = y
star_trans (Step x w) y = Step x (star_trans w y)

-- Exercise 3.2

public export
data Palindrome : List a -> Type where
  Nil  : Palindrome []
  (::) : (x : a) -> Palindrome xs -> Palindrome $ x :: xs ++ [x]

export
rev_of_palindrome : (xs : List a) -> Palindrome xs -> reverse xs = xs
rev_of_palindrome []               []     = Refl
rev_of_palindrome (x::(xs ++ [x])) (x::y) = rewrite sym $ revAppend (x::xs) [x] in
                                            rewrite sym $ revAppend [x] xs in
                                            rewrite rev_of_palindrome xs y in
                                            Refl

-- Exercise 3.3

public export
data Star' : (a -> a -> Type) -> a -> a -> Type where
  Refl' : Star' r x x
  Step' : {0 r : a -> a -> Type} -> Star' r x y -> r y z -> Star' r x z

export
star'_is_star : Star' r n m -> Star r n m
star'_is_star Refl'              = Refl
star'_is_star (Step' s'_ny r_ym) = star'_is_star s'_ny `star_trans` Step r_ym Refl

export
star'_trans : Star' r x y -> Star' r y z -> Star' r x z
star'_trans x Refl'       = x
star'_trans x (Step' y w) = Step' (star'_trans x y) w

export
star_is_star' : Star r x y -> Star' r x y
star_is_star' Refl       = Refl'
star_is_star' (Step x z) = Step' Refl' x `star'_trans` star_is_star' z

-- Execrise 3.4

public export
data Iter : (a -> a -> Type) -> Nat -> a -> a -> Type where
  IterZ : Iter r 0 x x
  IterS : {0 r : a -> a -> Type} -> r x y -> Iter r n y z -> Iter r (S n) x z

export
iter_then_star : Iter r n x y -> Star r x y
iter_then_star IterZ       = Refl
iter_then_star (IterS x z) = Step x (iter_then_star z)

export
star_then_some_iter : Star r x y -> (n ** Iter r n x y)
star_then_some_iter Refl       = (_ ** IterZ)
star_then_some_iter (Step x z) = (_ ** IterS x $ snd $ star_then_some_iter z)

-- Exercise 3.5

public export
data Alpha = A | B

namespace S
  public export
  data S : List Alpha -> Type where
    Empty : S []
    Asb   : {w : List Alpha} -> S w -> S $ [A] ++ w ++ [B]
    Ss    : {w, v : List Alpha} -> S w -> S v -> S $ w ++ v

namespace T
  public export
  data T : List Alpha -> Type where
    Empty : T []
    Tatb  : {w, v : List Alpha} -> T w -> T v -> T $ w ++ [A] ++ v ++ [B]

export
s_to_t : T w -> S w
s_to_t Empty              = Empty
s_to_t (Tatb {w} {v} x y) = Ss (s_to_t x) $ Asb $ s_to_t y

t_conj : {w : List Alpha} -> T w -> T v -> T (w ++ v)
t_conj x Empty = rewrite appendNilRightNeutral w in x
t_conj x (Tatb {v=a} {w=b} y z) = rewrite appendAssociative w b ([A] ++ a ++ [B]) in Tatb (t_conj x y) z

export
t_to_s : S w -> T w
t_to_s Empty    = Empty
t_to_s (Asb x)  = Tatb Empty $ t_to_s x
t_to_s (Ss x y) = t_conj (t_to_s x) (t_to_s y)


nil_app : (l : List Nat) -> ([] ++ l) = l
nil_app l = Refl

tl : List Nat -> List Nat
tl [] = []
tl (x :: xs) = xs

tl_length_pred : (l : List Nat) -> pred (length l) = length (tl l)
tl_length_pred [] = Refl
tl_length_pred (x :: xs) = Refl

app_assoc : (l1, l2, l3 : List Nat) -> ((l1 ++ l2) ++ l3) = (l1 ++ (l2 ++ l3))
app_assoc [] l2 l3 = Refl
app_assoc (x :: xs) l2 l3 = rewrite app_assoc xs l2 l3 in Refl

rev : (l : List Nat) -> List Nat
rev [] = []
rev (x :: xs) = (rev xs) ++ [x]

test_rev1 : rev [1, 2, 3] = [3, 2, 1]
test_rev1 = Refl

test_rev2 : rev [] = []
test_rev2 = Refl

app_length : (l1, l2 : List Nat) -> length (l1 ++ l2) = (length l1) + (length l2)
app_length [] l2 = Refl
app_length (x :: xs) l2 = rewrite app_length xs l2 in Refl

rev_length_firsttry : (l : List Nat) -> length (rev l) = length l
rev_length_firsttry [] = Refl
rev_length_firsttry (x :: xs) =
    rewrite app_length (rev xs) [x]
        in rewrite plusCommutative (length (rev xs)) 1
            in rewrite rev_length_firsttry xs
                in Refl

app_nil_r : (l : List Nat) -> (l ++ []) = l
app_nil_r [] = Refl
app_nil_r (x :: xs) = rewrite app_nil_r xs in Refl

rev_app_distr : (l1, l2 : List Nat) -> rev (l1 ++ l2) = (rev l2) ++ (rev l1)
rev_app_distr [] l2 =
    rewrite sym (app_nil_r l2)
        in rewrite app_nil_r (rev (l2 ++ []))
            in Refl
rev_app_distr (x :: xs) l2 =
    rewrite rev_app_distr xs l2
        in rewrite app_assoc (rev l2) (rev xs) [x]
            in Refl

rev_involutive : (l : List Nat) -> rev (rev l) = l
rev_involutive [] = Refl
rev_involutive (x :: xs) =
    rewrite rev_app_distr (rev xs) [x]
        in rewrite rev_involutive xs
            in Refl

app_assoc4 : (l1, l2, l3, l4 : List Nat) -> (l1 ++ (l2 ++ (l3 ++ l4))) = ((l1 ++ l2) ++ l3) ++ l4
app_assoc4 [] l2 l3 l4 = rewrite app_assoc l2 l3 l4 in Refl
app_assoc4 (x :: xs) l2 l3 l4 = rewrite app_assoc4 xs l2 l3 l4 in Refl

nonzeros : List Nat -> List Nat
nonzeros [] = []
nonzeros (Z :: xs) = nonzeros xs
nonzeros (k :: xs) = k :: nonzeros xs

nonzeros_app : (l1, l2 : List Nat) -> nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2)
nonzeros_app [] l2 = Refl
nonzeros_app (Z :: xs) l2 = rewrite nonzeros_app xs l2 in Refl
nonzeros_app ((S k) :: xs) l2 = rewrite nonzeros_app xs l2 in Refl

beq_list_nat : (l1, l2 : List Nat) -> Bool
beq_list_nat [] [] = True
beq_list_nat (x :: xs) (y :: ys) = x == y && beq_list_nat xs ys
beq_list_nat xs ys = False

test_beq_list_nat1 : beq_list_nat [] [] = True
test_beq_list_nat1 = Refl

test_beq_list_nat2 : beq_list_nat [1, 2, 3] [1, 2, 3] = True
test_beq_list_nat2 = Refl

test_beq_list_nat3 : beq_list_nat [1, 2, 3] [1, 2, 4] = False
test_beq_list_nat3 = Refl

beq_list_nat_refl : (l : List Nat) -> True = beq_list_nat l l
beq_list_nat_refl [] = Refl
beq_list_nat_refl (Z :: xs) = rewrite beq_list_nat_refl xs in Refl
beq_list_nat_refl ((S k) :: xs) =
    rewrite beq_list_nat_refl (k :: xs) in
        Refl

total
rev_injective : (l1, l2 : List Nat) -> rev l1 = rev l2 -> l1 = l2
rev_injective [] [] prf = Refl
rev_injective xs ys prf =
    rewrite sym $ rev_involutive xs in
        rewrite sym $ rev_involutive ys in
            rewrite prf in
                Refl


||| Implementation of ordering relations for `Nat`ural numbers
module Data.Nat.Order

import Data.Nat
import Data.Fun
import Data.Rel
import Decidable.Decidable
import Decidable.Equality
import Decidable.Order

public export
total LTEIsTransitive : (m : Nat) -> (n : Nat) -> (o : Nat) ->
                           LTE m n -> LTE n o ->
                           LTE m o
LTEIsTransitive Z n o                 LTEZero                  nlteo   = LTEZero
LTEIsTransitive (S m) (S n) (S o) (LTESucc mlten)    (LTESucc nlteo)   = LTESucc (LTEIsTransitive m n o mlten nlteo)

public export
total LTEIsReflexive : (n : Nat) -> LTE n n
LTEIsReflexive Z      = LTEZero
LTEIsReflexive (S n)  = LTESucc (LTEIsReflexive n)

public export
implementation Preorder Nat LTE where
  transitive = LTEIsTransitive
  reflexive  = LTEIsReflexive

public export
total LTEIsAntisymmetric : (m : Nat) -> (n : Nat) ->
                              LTE m n -> LTE n m -> m = n
LTEIsAntisymmetric Z Z         LTEZero LTEZero = Refl
LTEIsAntisymmetric (S n) (S m) (LTESucc mLTEn) (LTESucc nLTEm) with (LTEIsAntisymmetric n m mLTEn nLTEm)
   LTEIsAntisymmetric (S n) (S n) (LTESucc mLTEn) (LTESucc nLTEm)    | Refl = Refl

public export
implementation Poset Nat LTE where
  antisymmetric = LTEIsAntisymmetric

public export
total zeroNeverGreater : {n : Nat} -> LTE (S n) Z -> Void
zeroNeverGreater {n} LTEZero     impossible
zeroNeverGreater {n} (LTESucc _) impossible

public export
total zeroAlwaysSmaller : {n : Nat} -> LTE Z n
zeroAlwaysSmaller = LTEZero

public export
total ltesuccinjective : {0 n : Nat} -> {0 m : Nat} -> (LTE n m -> Void) -> LTE (S n) (S m) -> Void
ltesuccinjective {n} {m} disprf (LTESucc nLTEm) = void (disprf nLTEm)
ltesuccinjective {n} {m} disprf LTEZero         impossible

public export
total decideLTE : (n : Nat) -> (m : Nat) -> Dec (LTE n m)
decideLTE    Z      y  = Yes LTEZero
decideLTE (S x)     Z  = No  zeroNeverGreater
decideLTE (S x)   (S y) with (decEq (S x) (S y))
  decideLTE (S x)   (S y) | Yes eq      = rewrite eq in Yes (reflexive (S y))
  decideLTE (S x)   (S y) | No _ with (decideLTE x y)
  decideLTE (S x)   (S y) | No _   | Yes nLTEm = Yes (LTESucc nLTEm)
  decideLTE (S x)   (S y) | No _   | No  nGTm  = No (ltesuccinjective nGTm)

public export
implementation Decidable [Nat,Nat] LTE where
  decide = decideLTE

public export
total
lte : (m : Nat) -> (n : Nat) -> Dec (LTE m n)
lte m n = decide {ts = [Nat,Nat]} {p = LTE} m n

public export
total
shift : (m : Nat) -> (n : Nat) -> LTE m n -> LTE (S m) (S n)
shift m n mLTEn = LTESucc mLTEn

public export
implementation Ordered Nat LTE where
  order Z      n = Left LTEZero
  order m      Z = Right LTEZero
  order (S k) (S j) with (order {to=LTE} k j)
    order (S k) (S j) | Left  prf = Left  (shift k j prf)
    order (S k) (S j) | Right prf = Right (shift j k prf)


> module Predicates

> import Prelude.Maybe
> import Data.Fin
> import Control.Isomorphism

> import Sigma.Sigma

> %default total
> %access public export

> ||| Notion of finiteness for types
> Finite : Type -> Type
> Finite A = Sigma Nat (\ n => Iso A (Fin n))

> Finite0 : Type -> Type
> Finite0 = Finite

> Finite1 : {A : Type} -> (P : A -> Type) -> Type
> Finite1 {A} P = (a : A) -> Finite0 (P a)

> {-

This definition requires an exact cardinality |n| which may be
difficult to compute. But it is enough to know a finite bound, so an
alternative definition which may be more convenient is the following:

> FiniteSub : Type -> Type
> FiniteSub A = Exists (\ n => EmbProj A (Fin n))

----------------

> FiniteN : Nat -> Type -> Type
> FiniteN n A = Iso A (Fin n)

> ---}


module xquant.Core.Types

import public Data.Complex
import public Data.Matrix

%default total

Fl : Type
Fl = Float

Amp : Type
Amp = Complex Fl

---- Hilbert Space types ----

||| State vector type for n-dimensional complex Hilbert space
StateSpace : Nat -> Type -> Type
StateSpace n a = Vect n (Complex a)

||| Quantum observable type, n x n complex matrices
Op : Nat -> Type -> Type
Op n a = Matrix n n (Complex a)

||| Ket vector, a n x 1 matrix collumn
KetSpace : Nat -> Type -> Type
KetSpace n a = Matrix n 1 (Complex a)

||| Bra vector, a 1 x n matrix row
BraSpace : Nat -> Type -> Type
BraSpace n a = Matrix 1 n (Complex a)

||| Qubit state space type, 2^n dimensional Hilbert space
Qubit : Nat -> Type -> Type
Qubit n a = StateSpace (power 2 n) a

||| Qubit observable type
QubitOp : Nat -> Type -> Type
QubitOp n a = let m = power 2 n in Matrix m m (Complex a)

||| Qubit collumn vector type
QubitKet : Nat -> Type -> Type
QubitKet n a = let m = power 2 n in Matrix m 1 (Complex a)

||| Qubit row vector type
QubitBra : Nat -> Type -> Type
QubitBra n a = let m = power 2 n in Matrix 1 m (Complex a)

c0 : Num a => Complex a
c0 = 0 :+ 0

c1 : Num a => Complex a
c1 = 1 :+ 0

ci : Num a => Complex a
ci = 0 :+ 1

m1 : (Neg a, Num a) => Complex a
m1 = -1 :+ 0

mi : (Neg a, Num a) => Complex a
mi = 0 :+ -1

-- sqn : (Foldable t, Functor t) => t Amp -> Amp
-- sqn = sum' . map ((\x => conjugate x * x))

-- normalize : (Foldable t, Functor t) => t Amp -> t Amp
-- normalize xs = let n = sqn xs in map (map (\x => xn))
-- Can't resolve type class Functor f
-- normalize : Vect n

---- Relativistic types ----

Mink : Type
Mink = Vect 4 Amp

MinkR : Type
MinkR = Vect 4 Fl


module Mergesort

import Data.Vect

import Evens

-- import SortingWithProof

total
NatVect : Nat -> Type
NatVect n = Vect n Nat

total
SortProof : (n : Nat) -> (NatVect n) -> (Fin n) -> Type
SortProof Z v a impossible
SortProof (S k) v l = LTE (Vect.index (pred l) v) (Vect.index l v)

total
IsSorted : (n : Nat) -> (v : (NatVect n)) -> Type
IsSorted n v = (k : Fin n) -> (SortProof n v k)

--Takes the first m elements from a vector
Vecttake : (m:Nat)->Vect n elem -> LTE m n -> Vect m  elem
Vecttake Z xs LTEZero = []
Vecttake (S k) (x::xs) (LTESucc pf) = x::(Vecttake k xs pf)

--Takes the last m elements from a vector
Vecttakefromlast :(m:Nat)->Vect n elem -> LTE m n ->Vect m elem
Vecttakefromlast m xs pf = reverse (Vecttake  m (reverse xs) pf)

-- Inserts an element at the end of the vector
insertend : (x:elem)->Vect n elem->Vect (S n) elem
insertend x [] = [x]
insertend x (y :: xs) = y::(insertend x xs)

--apNat as defined in class. Lemma that proves that if n = m, then f(n) = f(m)
apNat : (f: Nat -> Nat) -> (n: Nat) -> (m: Nat) -> n = m -> f n = f m
apNat f m m Refl = Refl

--defined in class. Returns n/2 if n is even
half : (n: Nat) -> IsEven n -> Nat
half Z ZEven = 0
half (S (S k)) (SSEven k x) = S (half k x)

--returns (n - 1)/2 if (n + 1) is odd
halfnMinusone : (n : Nat) -> (IsEven (S n)) -> Nat
halfnMinusone (S Z) (SSEven Z ZEven) = Z
halfnMinusone (S (S k)) (SSEven (S k) pf) = S(halfnMinusone k pf)

-- lemma that proves that n is LTE S n
nLTESn : (n : Nat) -> LTE n (S n)
nLTESn Z = LTEZero
nLTESn (S k) = LTESucc (nLTESn k)

-- lemma that proves that if n is even, then half n is LTE n
halfnLTEn : (n: Nat) -> (pf : IsEven n) -> LTE (half n pf) n
halfnLTEn Z ZEven = LTEZero
halfnLTEn (S (S k)) (SSEven k p) =  lteTransitive (LTESucc (halfnLTEn k p)) (nLTESn (S k))

-- lemma that proves that if S n is even, then half S n is LTE n
halfSnLTEn : (n : Nat) -> (pf : IsEven (S n)) -> LTE (half (S n) pf) n
halfSnLTEn (S Z) (SSEven Z ZEven) = LTESucc LTEZero
halfSnLTEn (S (S k)) (SSEven (S k) pf) = lteTransitive (LTESucc (halfSnLTEn k pf)) (nLTESn (S k))

-- lemma that proves that if S n is even, then (n - 1)/2 is LTE n
halfnMinusoneLTEn : (n : Nat) -> (pf : IsEven (S n)) -> LTE (halfnMinusone n pf) n
halfnMinusoneLTEn (S Z) (SSEven Z ZEven) = LTEZero
halfnMinusoneLTEn (S (S k)) (SSEven (S k) pf) = lteTransitive (LTESucc (halfnMinusoneLTEn k pf)) (nLTESn (S k))

-- lemma that proves that if a = b, then a is LTE b
-- IMPORTANT : this is not Total
equalImpliesLTE : (a : Nat) -> (b : Nat) -> (a = b) -> LTE a b
equalImpliesLTE Z Z Refl = LTEZero
equalImpliesLTE (S k) (S k) Refl = LTESucc (equalImpliesLTE k k Refl)

-- proof that if n is even, then (n/2 + n/2) = n
nEqualhalfnplushalfn : (n : Nat) -> (pf : IsEven n) -> ((half n pf) + (half n pf)) = n
nEqualhalfnplushalfn Z ZEven = Refl
nEqualhalfnplushalfn (S (S k)) (SSEven k x) = rewrite (sym (plusSuccRightSucc (S (half k x)) (half k x))) in (cong {f = \l => (S (S l))} (nEqualhalfnplushalfn k x))

-- proof that if n is even, then n is LTE (n/2 + n/2)
nLTEhalfnplushalfn : (n : Nat) -> (pf : IsEven n) -> LTE n ((half n pf) + (half n pf))
nLTEhalfnplushalfn n pf = equalImpliesLTE n ((half n pf) + (half n pf)) (sym (nEqualhalfnplushalfn n pf))

-- proof that if S n is even, then ((n + 1)/2 + (n - 1)/2) = n
nEqualhalfOddn : (n : Nat) -> (pf : IsEven (S n)) -> ((half (S n) pf) + (halfnMinusone n pf)) = n
nEqualhalfOddn (S Z) (SSEven Z ZEven) = Refl
nEqualhalfOddn (S (S k)) (SSEven (S k) pf) = rewrite (sym (plusSuccRightSucc (S (half (S k) pf)) (halfnMinusone k pf))) in (cong {f = \l => (S (S l))} (nEqualhalfOddn k pf))

-- proof that if S n is even, then n is LTE ((n + 1)/2 + (n - 1)/2)
nLTEhalfOddn : (n : Nat) -> (pf : IsEven (S n)) -> LTE n ((half (S n) pf) + (halfnMinusone n pf))
nLTEhalfOddn n pf = equalImpliesLTE n ((half (S n) pf) + (halfnMinusone n pf)) (sym (nEqualhalfOddn n pf))

-- proof the n is either odd or even (done in class)
nOrSnEven: (n: Nat) -> Either (IsEven n) (IsEven (S n))
nOrSnEven Z = Left ZEven
nOrSnEven (S k) = case (nOrSnEven k) of
                       (Left l) => Right (SSEven k l)
                       (Right r) => Left r

-- function that takes a vector of even length, and divides it into two equal halves
halfVectEven : Vect n elem -> (pf : IsEven n) -> ((Vect (half n pf) elem), (Vect (half n pf) elem))
halfVectEven {n} xs pf = ((Vecttake (half n pf) xs (halfnLTEn n pf)), (Vecttakefromlast (half n pf) xs (halfnLTEn n pf)))

-- function that takes a vector of odd length, and divides it into two unequal parts ((n + 1)/2 and (n - 1)/2)
halfVectOdd : Vect n elem -> (pf : IsEven (S n)) -> ((Vect (half (S n) pf) elem), (Vect (halfnMinusone n pf) elem))
halfVectOdd {n} xs pf = ((Vecttake (half (S n) pf) xs (halfSnLTEn n pf)), (Vecttakefromlast (halfnMinusone n pf) xs (halfnMinusoneLTEn n pf)))

-- proof that n is LTE n (proved in class)
reflLTE : (n: Nat) -> LTE n n
reflLTE Z = LTEZero
reflLTE (S k) = LTESucc (reflLTE k)

-- lemma that a is LTE ((S a) + b)
lemma1 : (a : Nat) -> (b: Nat) -> LTE a ((S a) + b)
lemma1 Z b = LTEZero
lemma1 (S k) b = LTESucc (lemma1 k b)

-- lemma that (S (a + b)) is LTE (a + S b)
lemma2 : (a : Nat) -> (b : Nat) -> LTE (S (a + b)) (a + (S b))
lemma2 Z b = reflLTE (S b)
lemma2 (S k) b = LTESucc (lemma2 k b)

-- lemma that (S b) is LTE ((S a) + b)
lemma3 : (a : Nat) -> (b : Nat) -> LTE (S b) ((S a) + b)
lemma3 a Z = LTESucc LTEZero
lemma3 a (S k) = lteTransitive (LTESucc (lemma3 a k)) (lemma2 (S a) k)

--these are functions to cast a vector from one type to another
sillycast: (Vect ((S k) + j) elem) ->( Vect (k+ (S j)) elem)
sillycast {k} {j} v1 = (Vecttake k v1 (lemma1 k j)) ++ (Vecttakefromlast (S j) v1 (lemma3 k j))

sillycastEven : (n : Nat) -> (pf : IsEven n) -> (Vect ((half n pf) + (half n pf)) elem) -> Vect n elem
sillycastEven n pf xs = Vecttake n xs (nLTEhalfnplushalfn n pf)

sillycastOdd : (n : Nat) -> (pf : IsEven (S n)) -> (Vect ((half (S n) pf) + (halfnMinusone n pf)) elem) -> Vect n elem
sillycastOdd n pf xs = Vecttake n xs (nLTEhalfOddn n pf)

--The merge function
merge1 :Ord elem =>Vect  n elem ->Vect  m elem ->Vect (n+m) elem
merge1 [] ys = ys
merge1  (x :: xs) [] =  (x::xs)++[]
merge1 {n= (S k)}{m= (S j)} (x :: xs) (y :: ys) = case x<=y of
                                 False => y::(sillycast( (merge1  (x::xs) ys)))
                                 True => x::(merge1 xs (y::ys))

mergeNat : (v1 : (NatVect n)) -> (v2 : (NatVect m)) -> (NatVect (n + m))
mergeNat v1 v2 = merge1 v1 v2

--The mergesort function
-- working of mergesort :
-- Step 1 : Checks if the lenght of the vector is odd or Even
-- Step 2 : if Even -> split into two equal parts (n/2 , n/2 )
--          if Odd -> split into two unequal parts ( (n + 1)/2 , (n - 1)/2)
-- Step 3 : apply mergesort recursively on the two parts
-- Step 4 : merge the two sorted parts according to the merge1 function
-- Step 5 : The vector obtained from merge will be of the type Vect (a + b) elem,
--  where (a + b) = n. The Vector is cast into the type Vect n elem by the
--  sillycast functions.
mergesort :Ord elem => Vect n elem -> Vect n elem
mergesort [] = []
mergesort [x] = [x]
mergesort {n} xs = case (nOrSnEven n) of
                    (Left nEven) => sillycastEven n nEven (merge1 (mergesort (fst(halfVectEven xs nEven))) (mergesort (snd(halfVectEven xs nEven))))
                    (Right snEven) => sillycastOdd n snEven (merge1 (mergesort (fst(halfVectOdd xs snEven))) (mergesort (snd(halfVectOdd xs snEven))))

--GOAL : To prove that mergesort v is sorted for all vectors v with elem = Nat

-- Given a sorted vector (call it v) and an element (call it x) that is LTE the first element of v, proof that (x :: v) is sorted
total
addElemSorted : (x : Nat) -> (v : NatVect (S k)) -> (LTE x (Vect.index (FZ) v)) -> IsSorted (S k) v -> IsSorted (S (S k)) (x :: v)
addElemSorted x v pf1 pf2 FZ = reflLTE (Vect.index (FZ) (x :: v))
addElemSorted x v pf1 pf2 (FS FZ) = pf1
addElemSorted x v pf1 pf2 (FS (FS j)) = (pf2 (FS j))

-- mergeNatIsSorted : (v1 : Vect n Nat) -> (IsSorted n v1) -> (v2 : Vect m Nat) -> (IsSorted m v2) -> IsSorted (n + m) (mergeNat v1 v2)
-- mergeNatIsSorted {n = (S k)} {m = (S j)} (z :: xs) x (w :: ys) y = case (isLTE z w) of
--                                                                   (Yes pf) => addElemSorted z (mergeNat xs (w :: ys)) pf (mergeNatIsSorted xs x (w :: ys) y)
--                                                                   (No contra) => ?rhs


module OfficialCrashCourse.DTypes

-- Data Types
public export
data NatNum = Hero | Succ NatNum  -- natural numbers are either Zero or Successor of another natural number

public export
data PolyList a = Nil | (::) a (PolyList a)  -- a is a type variable, a polymorphic list is either nil or is a value of type a 'cons'-ed to a polymorphic list of the same type


||| Tabulation gives a bijection between functions `f : Fin n -> a`
||| (up to extensional equality) and vectors `tabulate f : Vect n a`.
module Data.Vect.Properties.Tabulate

import Data.Vect
import Data.Fin

||| Vectors are uniquely determined by their elements
export
vectorExtensionality
  : (xs, ys : Vect n a) -> (ext : (i : Fin n) -> index i xs = index i ys)
 -> xs = ys
vectorExtensionality    []        []     ext = Refl
vectorExtensionality (x :: xs) (y :: ys) ext =
  cong2 (::)
        (ext FZ)
        (vectorExtensionality xs ys (\i => ext (FS i)))

||| Extensionally equivalent functions tabulate to the same vector
export
tabulateExtensional
  : {n : Nat} -> (f, g : Fin n -> a) -> (ext : (i : Fin n) -> f i = g i)
 -> tabulate f = tabulate g
tabulateExtensional {n = 0  } f g ext = Refl
tabulateExtensional {n = S n} f g ext =
  cong2 (::) (ext FZ) (tabulateExtensional (f . FS) (g . FS) (\ i => ext $ FS i))

||| Taking an index amounts to applying the tabulated function
export
indexTabulate : {n : Nat} -> (f : Fin n -> a) -> (i : Fin n) -> index i (tabulate f) = f i
indexTabulate f  FZ    = Refl
indexTabulate f (FS i) = indexTabulate (f . FS) i

||| The empty vector represents the unique function `Fin 0 -> a`
export
emptyInitial : (v : Vect 0 a) -> v = []
emptyInitial [] = Refl