module sorting_with_proof

import Data.Vect
import Data.Fin

||| Vectors of Natural numbers
total
NatVect : Nat -> Type
NatVect n = Vect n Nat

||| The type Fin n -> Fin n
total
F_Fin : Nat -> Type
F_Fin n = (Fin n) -> (Fin n)

||| Identity function
total
Idt : (t : Type) -> t -> t
Idt s a = a

||| The type of permutation/bijection of {1,...,n}.
||| Notice that for finite sets one sided inverse is enough.
||| Also I have a strong feeling that using univalence the last part of the definition is
||| equivalent to saying that (g . f) and Idt are equivalent
total
Perm : Nat -> Type
Perm n = ( f : F_Fin n ** ( g : F_Fin n ** ((a : (Fin n)) -> ((g (f a)) = a))))

||| Second definition of perm. I have strong feeling that using univalence this is equivalent
||| to the first definition.
total
Perm2 : Nat -> Type
Perm2 n = ( f : F_Fin n ** ( g : F_Fin n ** ((g . f) = (Idt (Fin n)))))

data Finite : Nat -> Type where
    FinZ : (k : Nat) -> (Finite (S k))
    FinS : (k : Nat) -> (Finite k) -> (Finite (S k))

total
Finite_to_Fin : (k : Nat) -> (Finite k) -> (Fin k)
Finite_to_Fin Z a impossible
Finite_to_Fin (S k) (FinZ k) = FZ
Finite_to_Fin (S k) (FinS k nm) = FS (Finite_to_Fin k nm)

total
Fin_to_Finite : (k : Nat) -> (Fin k) -> (Finite k)
Fin_to_Finite Z a impossible
Fin_to_Finite (S k) FZ = FinZ k
Fin_to_Finite (S k) (FS l) = FinS k (Fin_to_Finite k l)

||| Predecessor function for finite
total
predFinite : (k : Nat) -> (Finite k) -> (Finite k)
predFinite Z a impossible
predFinite (S k) (FinZ k) = FinZ k
predFinite (S (S k)) (FinS (S k) (FinZ k)) = FinZ (S k)
predFinite (S (S k)) (FinS (S k) l) = FinS (S k) (predFinite (S k) l)

||| Predecessor function for fin
total
predFin : (n : Nat) -> (Fin n) -> (Fin n)
predFin n a = Finite_to_Fin n ( predFinite n (Fin_to_Finite n a))

||| Type of proofs that a vector is sorted in increasing order.
||| Note that the predecessor function takes care of the first index
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)

||| Type of the sorted vectors.
SortedVect : Type
SortedVect = (n : Nat ** (v : (NatVect n)  ** ((k : Fin n) -> (SortProof n v k))))


module Graph_alt

import Data.Fin
import Data.Vect
import fn_to_vect
import Matrix

||| Definition of a graph as it's adacency matrix
total
Graph : (n : Nat) -> Type
Graph n = Mat_Vect n n Bool

total
self_loops : (n : Nat) -> (Graph n)
self_loops n = Identity_Bool n

total
or : Bool -> Bool -> Bool
or False False = False
or _ _ = True

total
and : Bool -> Bool -> Bool
and True True = True
and _ _ = False

total
add_self_loops : (n : Nat) -> (Graph n) -> (Graph n)
add_self_loops n adj = addMat n n Bool or adj (self_loops n)

total
mulGraphs : (n : Nat) -> (Graph n) -> (Graph n) -> (Graph n)
mulGraphs n u v = ( mulMat n n n Bool and or False u v )

total
nth_power_of_adj : (n : Nat) -> (siz : Nat) -> (Graph siz) -> (Graph siz)
nth_power_of_adj Z siz adj = self_loops siz
nth_power_of_adj (S k) siz adj =
      mulGraphs siz adj (nth_power_of_adj k siz adj)

total
Is_path_of_length : (length : Nat) -> (siz : Nat) -> (Graph siz) ->
                    (i : Fin siz) -> (j : Fin siz) -> Bool
Is_path_of_length l siz adj i j =
      index j (index i (nth_power_of_adj l siz adj ))


{- 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 Vect : Nat -> Type -> Type where
  Nil : Vect 0 a
  (::) : a -> Vect n a -> Vect (S n) a

data EqNat : (n1 : Nat) -> (n2 : Nat) -> Type where
  Same : (n : Nat) -> EqNat n n

Show (EqNat n m) where
  show (Same n) = "Same " ++ show n

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

checkEqNat : (n1 : Nat) -> (n2 : Nat) -> Maybe (EqNat n1 n2)
checkEqNat Z Z = Just $ Same 0
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
  Nothing => Nothing
  Just eq => Just (sameS _ _ eq)

exactLength : (len : Nat) -> (input : Vect n a) -> Maybe (Vect len a)
exactLength {n} len input = case checkEqNat n len of
  Nothing => Nothing
  Just (Same len0) => Just input

checkEqNat2 : (n1 : Nat) -> (n2 : Nat) -> Maybe (n1 = n2)
checkEqNat2 Z Z = Just Refl
checkEqNat2 Z (S k) = Nothing
checkEqNat2 (S k) Z = Nothing
checkEqNat2 (S k) (S j) = map cong (checkEqNat2 k j)

sameCons : {xs : List a} -> {ys : List a} -> xs = ys -> x :: xs = x :: ys
sameCons prf = cong prf

sameList : {xs : List a} -> {ys : List a} -> x = y -> xs = ys -> x :: xs = y :: ys
sameList Refl prf2 = cong prf2

main : IO ()
main = do
  printLn $ Same 4
  printLn $ Same 5
  printLn $ the (EqNat 3 3) (Same _)
  printLn $ Same (2 + 2)
  printLn $ isJust $ exactLength 2 (0 :: 1 :: Nil)
  printLn $ isJust $ checkEqNat2 10 10
  printLn $ isNothing $ checkEqNat2 10 9


module chap07

-- 7.1.6 Exercises
data Shape = Triangle Double Double
           | Rectangle Double Double
           | Circle Double

Eq Shape where
  (==) (Triangle x y) (Triangle x' y') = x == x' && y == y'
  (==) (Rectangle x y) (Rectangle x' y') = x == x' && y == y'
  (==) (Circle d) (Circle d') = d == d'
  (==) _ _ = False

area : Shape -> Double
area (Triangle x y) = x * y / 2
area (Rectangle x y) = x * y
area (Circle x) = pi * x * x

Ord Shape where
    compare x y = compare (area x) (area y)

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 : (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)

-- interface Show a where
--  show : a -> String

-- 7.3.4 Exercises 1
Functor Expr where
    map func (Val x) = Val (func x)
    map func (Add x y) = Add (map func x) (map func y)
    map func (Sub x y) = Sub (map func x) (map func y)
    map func (Mul x y) = Mul (map func x) (map func y)
    map func (Div x y) = Div (map func x) (map func y)
    map func (Abs x) = Abs (map func x)

-- *chap07> map (*2) (the (Expr _) (1 + 2 * 3))
-- Add (Val 2) (Mul (Val 4) (Val 6)) : Expr Integer
-- *chap07> map show (the (Expr _) (1 + 2 * 3))
-- Add (Val "1") (Mul (Val "2") (Val "3")) : Expr String

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

-- Eq and Foldable
Eq ty => Eq (Vect n ty) where
    (==) [] [] = True
    (==) (x :: xs) (x' :: xs') = (x == x') && (xs == xs')

-- foldr : Foldable t => (elem -> acc -> acc) -> acc -> t elem -> acc
-- foldl : Foldable t => (acc -> elem -> acc) -> acc -> t elem -> acc

Foldable (Vect n) where
    foldr func acc [] = acc
    foldr func acc (x :: y) = func x (foldr func acc y)
    foldl func acc [] = ?Foldable_rhs_1
    foldl func acc (x :: y) = func (foldl func acc y) x

-- 7.2.4 Exercises

Show ty => Show (Expr ty) where
    show (Val x) = " " ++ show x ++ " "
    show (Add x y) = "(Add " ++ show x ++ show y ++ ")"
    show (Sub x y) = "(Sub " ++ show x ++ show y ++ ")"
    show (Mul x y) = "(Mul " ++ show x ++ show y ++ ")"
    show (Div x y) = "(Div " ++ show x ++ show y ++ ")"
    show (Abs x) = "(Abs " ++ show x ++ ")"

(Neg ty, Integral ty, Eq ty) => Eq (Expr ty) where
    (==) x y = (==) (eval x) (eval y)

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

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

  -- *chap07> Circle 2 == Circle 2
  -- True : Bool
  -- *chap07> Circle 2 == Circle 3
  -- False : Bool
  -- *chap07> Circle 2 == Rectangle 1 3
  -- False : Bool

-- counts the number of occurrences of a specific value, of some generic type ty, in a list
occurrences : Eq ty => (item : ty) -> (values : List ty) -> Nat
occurrences item [] = 0
occurrences item (x :: xs) = if item == x
                             then 1 + occurrences item xs
                             else occurrences item xs

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

Functor Tree where
  map f Empty = Empty
  map f (Node l e r) = Node (map f l) (f e) (map f r)

-- *chap07> map (*2) (Node (Node Empty 1 Empty) 5 (Node Empty 7 Empty))
-- Node (Node Empty 2 Empty) 10 (Node Empty 14 Empty) : Tree Integer

Foldable Tree where
    foldr func acc Empty = acc
    foldr func acc (Node l e r) = func e (foldr func (foldr func acc l) r)
    foldl func acc Empty = acc
    foldl func acc (Node l e r) = func (foldl func (foldl func acc r) l) e

-- *chap07> foldl (+) 0 (Node (Node Empty 1 Empty) 5 (Node Empty 7 (Node Empty 2 (Node Empty 1 Empty))))
-- 16 : Integer
-- *chap07> foldr (+) 0 (Node (Node Empty 1 Empty) 5 (Node Empty 7 (Node Empty 2 (Node Empty 1 Empty))))
-- 16 : Integer


{- This file demonstrates the canonical example of dependent types,
 - vectors (implemented as lists) with their lengths encoded at the type level.
 - First note that Idris has built-in natural numbers, defined as follows:

 data Nat = Z | S Nat

 - A Nat is either 0 (Z) or the successor of a Nat, (i.e. N + 1) -}

data Vect : Nat -> Type -> Type where
  Nil  : Vect Z elem
  (::) : (x : elem) -> (xs : Vect len elem) -> Vect (S len) elem

-- Hints for interactive editing
%name Vect xs,ys,zs,ws

{- Let's break this down. We have a type constructor
 -   Vect : Nat -> Type -> Type
 - In Idris, since types are values, type constructors are just functions!
 - This type constructor takes a value of type `Nat` and a value of type `Type`
 - and constructs the type (Vect N Type) of a length N vector of type Type.

 - We also have two term constructors, `Nil` and `(::)`.
 -   Nil : Vect z elem
 - constructs a vector of length `0` with element type `elem` for any type `elem`.
 -   (::) : (x : elem) -> (xs : Vect len elem) -> Vect (S len) elem
 - takes an element and a Vector of length `len`, and returns a vector of
 - length `len + 1`. Note that it does so by construction, i.e. this is where
 - we *define* how the length of a vector is calculated. -}

v1 : Vect 0 Int
v1 = [] -- [] is a built-in synonym for Nil

v2 : Vect 3 Int
v2 = [1,2,3] -- list syntax is overloaded for any type with constructors Nil, ::

-- The following code will throw a compile-time error
--   v3 : Vect 4 Int
--   v3 : [1,2,3]

{- Crucial to the defintion above is the fact that we can use functions to
 - compute types. For example, `Vect (len + 1) elem` uses addition to compute
 - the resulting type. We can write functions whose output types are computed
 - from their input types.

 - Let us write an append function on vectors. -}

append : Vect n a -> Vect m a -> Vect (n + m) a
append xs ys = ?hole

{- Here `?hole` is a hole, which is a valid piece of syntax that Idris can assign
 - a type. In the Idris editor mode (see https://atom.io/packages/language-idris),
 - the shortcut Ctrl-Alt-t shows the type of the value under the cursor as well
 - as the types of all the available values in scope. On the hole above, this yields

 0 m : Nat
 0 a : Type
 0 n : Nat
   ys : Vect m a
   xs : Vect n a
-------------------------------------
hole : Vect (plus n m) a

 - Ctrl-Alt-c on a function argument case splits that argument. Doing so on `xs`:
 -}

append2 : Vect n a -> Vect m a -> Vect (n + m) a
append2 [] ys = ?base2       -- base case
append2 (x :: xs) ys = ?rec2 -- recursive case

{- Inspecting ?base2, we see

 0 m : Nat
 0 a : Type
   ys : Vect m a
 0 n : Nat
-------------------------------------
base2 : Vect m a

- We require a `Vect m a` and have a `Vect m a`, ys.

- Ctrl-Alt-s searches the types and values in scope for a solution to the program,
- i.e. a term with the type of the hole. Running serach on the two holes above
- automatically generates the following code. -}

append3 : Vect n a -> Vect m a -> Vect (n + m) a
append3 [] ys = ys
append3 (x :: xs) ys = x :: append3 xs ys

{- This is amazing! The compiler just discovered our code for us! Note that all
 - this does is replace our usual reasoning "see what fits the type and its
 - probably right," and will thus not always yield the correct program. However,
 - the extra expressivity of dependent types does often allow correct program
 - generation, just via a simple search.

 - Let us consider another example: -}

zipWith : (f : a -> b -> c) -> (xs : Vect n a) -> (ys : Vect n b) -> Vect n c
zipWith f xs ys = ?zipWith_rhs

{- Here, both input vectors are guarenteed to be the same length. This gives
 - the compiler a lot of useful information to help us write our program.
 - First, Ctrl-Alt-c to case split on `xs` yields the following: -}

zipWith2 : (f : a -> b -> c) -> (xs : Vect n a) -> (ys : Vect n b) -> Vect n c
zipWith2 f [] ys = ?zipWith2_rhs_1
zipWith2 f (x :: xs) ys = ?zipWith2_rhs_2

{- Subsequently case splitting again on ys in both the base
 - and recursive case only yields the one possibility for each, since in the
 - base case `ys` is guarenteed to be `[]` and in the recursive case `ys` is
 - guarenteed to be of the form `(y :: ys)`. -}

zipWith3 : (f : a -> b -> c) -> (xs : Vect n a) -> (ys : Vect n b) -> Vect n c
zipWith3 f [] [] = ?zipWith_base
zipWith3 f (x :: xs) (y :: ys) = ?zipWith_rec

{- Searching w/ Ctrl-Alt-s on the two holes above immediately yields the solution! -}

zipWith4 : (f : a -> b -> c) -> (xs : Vect n a) -> (ys : Vect n b) -> Vect n c
zipWith4 f [] [] = []
zipWith4 f (x :: xs) (y :: ys) = f x y :: zipWith4 f xs ys


import Data.So

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

minVal : Ord a => Tree a -> Maybe a
minVal Leaf                      = Nothing
minVal (Node key Leaf _)         = Just key
minVal (Node key left right)     = minVal left

maxVal : Ord a => Tree a -> Maybe a
maxVal Leaf                      = Nothing
maxVal (Node key _ Leaf)         = Just key
maxVal (Node left key right)     = maxVal right

data Comp = LT | EQ | GT

lessTree : Ord a => a -> Tree a -> Bool
lessTree x node = case minVal node of
                   Nothing => True
                   Just key  => x < key

moreTree : Ord a => a -> Tree a -> Bool
moreTree x node = case maxVal node of
                   Nothing => True
                   Just key  => x >= key

comp : Ord a => a -> a -> Comp
comp x y = if x > y then GT else if x < y then LT else EQ

IsLft : Ord a => (x: a) -> (left: Tree a) -> Type
IsLft x left = So (moreTree x left)

IsRgt : Ord a => (x: a) -> (right: Tree a) -> Type
IsRgt x right = So (lessTree x right)

mkIsLft : Ord a => (x: a) -> (l: Tree a) -> (IsLft x l)
mkIsLft x l =
  case (choose (moreTree x l)) of
       Left proofYes => proofYes

mkIsRgt : Ord a => (x: a) -> (r: Tree a) -> (IsRgt x r)
mkIsRgt x r =
  case (choose (lessTree x r)) of
       Left proofYes => proofYes

data IsBST : (t : Tree a) -> Type where
  IsBSTLeaf : IsBST Leaf
  IsBSTNode : Ord a => (x: a) -> (IsBST left) -> (IsLft x left) -> (IsBST right) -> (IsRgt x right) -> (IsBST (Node x left right))

BSTree : Type -> Type
BSTree a = (t' : (Tree a) ** (IsBST t'))

insert : Ord a => (x : a) -> BSTree a -> BSTree a
insert x (Leaf ** IsBSTLeaf) =
  let isLftPrf = mkIsLft x Leaf
      isRgtPrf = mkIsRgt x Leaf
  in  ((Node x Leaf Leaf) ** (IsBSTNode x IsBSTLeaf isLftPrf IsBSTLeaf isRgtPrf))
insert x ((Node y left right) ** (IsBSTNode y lPrf isLftPrf rPrf isRgtPrf)) =
  case comp y x of
       GT =>
       let (lTree ** pl) = insert x (left ** lPrf)
           isLft         = mkIsLft y lTree
       in  ((Node y lTree right) ** (IsBSTNode y pl isLft rPrf isRgtPrf))
       LT =>
       let (rTree ** pr) = insert x (right ** rPrf)
           isRgt         = mkIsRgt y rTree
       in  ((Node y left rTree) ** (IsBSTNode y lPrf isLftPrf pr isRgt))
       EQ => ((Node y left right) ** (IsBSTNode y lPrf isLftPrf rPrf isRgtPrf))

-- wrongInsert : Ord a => (x : a) -> BSTree a -> BSTree a
-- wrongInsert x (Leaf ** IsBSTLeaf)  =
--   let isLftPrf = mkIsLft x Leaf
--       isRgtPrf = mkIsRgt x Leaf
--   in  ((Node x Leaf Leaf) ** (IsBSTNode x IsBSTLeaf isLftPrf IsBSTLeaf isRgtPrf))
-- wrongInsert x ((Node y left right) ** (IsBSTNode y lPrf isLftPrf rPrf isRgtPrf)) =
--   case comp y x of
--        GT =>
--        let (lTree ** pl) = insert x (left ** lPrf)
--            isLft         = mkIsLft y lTree
--        in  ((Node y right lTree) ** (IsBSTNode y rPrf isRgtPrf pl isLft))
--        LT =>
--        let (rTree ** pr) = insert x (right ** rPrf)
--            isRgt         = mkIsRgt y rTree
--        in  ((Node y left rTree) ** (IsBSTNode y lPrf isLftPrf pr isRgt))
--        EQ => ((Node y left right) ** (IsBSTNode y lPrf isLftPrf rPrf isRgtPrf))


module NamedImplementations

import Data.List

%default total

-- named implementations allow us to have multiple implementations for a particular interface
-- for a particular type.

{-
  [name] Interface Type where
    func

  and then use as: func @{name} instead of the normal func
-}

[myord] Ord Nat where
  compare Z (S k) = GT
  compare (S k) Z = LT
  compare Z Z = EQ
  compare (S k) (S j) = compare @{myord} k j

testList : List Nat
testList = [3, 4, 1, 2, 3, 5, 4, 4, 5]

normalSort : List Nat -> List Nat
normalSort = sort

reverseSort : List Nat -> List Nat
reverseSort = sort @{myord} -- use the custom interface implementation with the name `myord`

-- this is something that Haskell cannot do - and the reason why it has to define wrapper classes
-- like `Sum` and `Product` in the Data.Monoid module. Named Implementations provides an elegant way
-- out of this boilerplate.

{-
  interface Semigroup ty where
    (<+>) : ty -> ty -> ty

  interface Semigroup ty => Monoid ty where
    neutral : ty
-}

[PlusNatSemi] Semigroup Nat where
  (<+>) x y = x + y

[MultNatSemi] Semigroup Nat where
  (<+>) x y = x * y

[PlusNatMonoid] Monoid Nat using PlusNatSemi where -- note the `using` clause
  neutral = 0

[MultNatMonoid] Monoid Nat using MultNatSemi where
  neutral = 1


import Data.Vect

{- 1 -}

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

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

{- 2 -}

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

{- 3 -}

multVecs : Num a => (xs : Vect n a) -> (ys : Vect n a) -> a
multVecs xs ys = sum (zipWith (*) xs ys)

mkRow : Num a => (x : Vect n a) -> (ys_trans : Vect p (Vect n a)) -> Vect p a
mkRow x [] = []
mkRow x (y :: xs) = multVecs x y :: mkRow x xs

multMatrix_helper : Num a => (xs : Vect m (Vect n a)) -> (ys_trans : Vect p (Vect n a)) -> Vect m (Vect p a)
multMatrix_helper [] ys_trans = []
multMatrix_helper (x :: xs) ys_trans
     = mkRow x ys_trans :: multMatrix_helper xs ys_trans

multMatrix : Num a => Vect m (Vect n a) -> Vect n (Vect p a) -> Vect m (Vect p a)
multMatrix xs ys = let ys_trans = transpose_mat ys in
                       multMatrix_helper xs ys_trans


module arkaghosh.Odds

import Evens

import Intro

||| inductive type family IsOdd (Ques 1)
data IsOdd : Nat -> Type where
    SZOdd : IsOdd (S Z)
    SSOdd : (n : Nat) -> (IsOdd n) -> (IsOdd (S (S n)))

||| witness that 3 is odd (Ques 2)
threeOddProof : IsOdd 3
threeOddProof = SSOdd 1 SZOdd

||| witness that 2 is not odd (Ques 3)
total
twoNotOdd : (IsOdd 2) -> Void
twoNotOdd SZOdd impossible -- twoNotOdd will be total even without this line
twoNotOdd (SSOdd Z pf) impossible

||| Property 1 - If n is odd then (S n) is even (Ques 4)
total
prop1 : (n : Nat) -> (IsOdd n) -> (IsEven (S n))
prop1 (S Z) SZOdd = SSEven Z ZEven
prop1 (S (S n)) (SSOdd n pf) = SSEven (S n) (prop1 n pf)

||| Property 2 - If n is even then (S n) is odd (Ques 5)
total
prop2 : (n : Nat) -> (IsEven n) -> (IsOdd (S n))
prop2 Z ZEven = SZOdd
prop2 (S (S n)) (SSEven n pf) = SSOdd (S n) (prop2 n pf)

||| Property 3 -  No number is both even and odd (Ques 7)
total
prop3 : (n : Nat) -> (IsOdd n) -> (IsEven n) -> Void
prop3 Z pf ZEven impossible
prop3 (S Z) SZOdd pf impossible
prop3 (S (S n)) (SSOdd n pf1) (SSEven n pf2) = prop3 n pf1 pf2

||| Property 4 - If n and m are odd, then (n + m) is even (Ques 8)
total
prop4 : (n : Nat) -> (m : Nat) -> (IsOdd n) -> (IsOdd m) -> (IsEven (add n m))
prop4 Z m pf1 pf2 impossible
prop4 (S Z) m pf1 pf2 = prop1 m pf2
prop4 (S (S n)) m (SSOdd n pf1) pf2 = SSEven (add n m) (prop4 n m pf1 pf2)

||| Property 5 -  Every number n : Nat is either even or odd (Ques 6)
total
prop5 : (n : Nat) -> Either (IsEven n) (IsOdd n)
prop5 Z = Left ZEven
prop5 (S n) = f n  (prop5 n)
    where f : (m : Nat) -> (Either (IsEven m) (IsOdd m)) -> (Either (IsEven (S m)) (IsOdd (S m)))
          f m (Left pf) = Right (prop2 m pf)
          f m (Right pf) = Left (prop1 m pf)

||| Congruence : If n = m then f(n) = f(m)
total
congruence : (a : Type) -> (f : a -> a) -> (n : a) -> (m : a) -> (n = m) -> (f(n) = f(m))
congruence typ f n n Refl = Refl

||| Property 6 - if n is odd, then there exists m such that n = 2m + 1 (Ques 9)
total
prop6 : (n : Nat) -> (IsOdd n) -> ( k: Nat ** S(double k) = n )
prop6 (S Z) SZOdd = (Z ** Refl)
prop6 (S (S n)) (SSOdd n pf) = ( (S m) ** pf1)
    where m : Nat
          pf2 : S(double m) = n
          m = fst(prop6 n pf)
          pf2 = snd(prop6 n pf)
          pf1 : S(double (S m)) = (S (S n))
          pf1 = congruence Nat f (S(double m)) n pf2
              where f : Nat -> Nat
                    f x = S( S x)


module Solution

namespace Preloaded

  %access export
  %default total

  ltePlus : LTE m1 n1 -> LTE m2 n2 -> LTE (m1 + m2) (n1 + n2)
  ltePlus {n1=Z} LTEZero lte = lte
  ltePlus {n1=S k} LTEZero lte = lteSuccRight $ ltePlus {n1=k} LTEZero lte
  ltePlus (LTESucc lte1) lte2 = LTESucc $ ltePlus lte1 lte2

  lteMult : LTE m1 n1 -> LTE m2 n2 -> LTE (m1 * m2) (n1 * n2)
  lteMult LTEZero _ = LTEZero
  lteMult {m1=S k} (LTESucc _) LTEZero = rewrite multZeroRightZero k in LTEZero
  lteMult (LTESucc lte1) (LTESucc lte2) = LTESucc $ ltePlus lte2 $ lteMult lte1 $ LTESucc lte2

  lteCongMult : (k : Nat) -> LTE m n -> LTE (m * k) (n * k)
  lteCongMult k lte = lteMult lte lteRefl

  lteCongMultLeft : (k : Nat) -> LTE m n -> LTE (k * m) (k * n)
  lteCongMultLeft k lte = lteMult lteRefl lte

%access export
%default total

-- Task 1. Prove that the successor of a Nat cannot be ≤ zero.
notSuccLteZero : Not (S n `LTE` Z)
notSuccLteZero LTEZero impossible

-- Task 2. Prove that you can add any Nat to the right side of a ≤-property.

lteStepK : (k : Nat) -> m `LTE` n -> m `LTE` k + n
lteStepK _ = ltePlus LTEZero

-- Task 3. Prove that you can remove "addition on the left" from both sides of a ≤-property.

plusLteInjLeft : (a : Nat) -> a + b `LTE` a + c -> b `LTE` c
plusLteInjLeft Z     abc         = abc
plusLteInjLeft (S k) (LTESucc x) = plusLteInjLeft k x

-- Task 4. Prove that you can remove "multiplication on the left" from both sides of a <-property.

succGoesOut : (x, y, a : Nat) -> x + a * (S y) = a + (x + a * y)
succGoesOut x y a = rewrite multRightSuccPlus a y in
                    rewrite plusCommutative x $ a + (a*y) in
                    rewrite sym $ plusAssociative a (a*y) x in
                    rewrite plusCommutative (a*y) x in
                    Refl

multLtInjLeft : a * b `LT` a * c -> b `LT` c
multLtInjLeft {a=Z}   {b}     {c}     = \LTEZero impossible
multLtInjLeft {a=S a} {b=Z}   {c=Z}   = rewrite multZeroRightZero a in id
multLtInjLeft {a=S a} {b=Z}   {c=S c} = \_ => LTESucc LTEZero
multLtInjLeft {a=S a} {b=S b} {c=Z}   = rewrite multZeroRightZero a in \LTEZero impossible
multLtInjLeft {a=S a} {b=S b} {c=S c} = rewrite succGoesOut b b a in
                                        rewrite succGoesOut c c a in
                                        rewrite plusSuccRightSucc a $ b + a*b in
                                        \(LTESucc lt) => LTESucc . multLtInjLeft {a=S a} $ plusLteInjLeft a lt

-- Task 5. Prove this.

lteDelta : x `LTE` y -> (d ** x + d = y)
lteDelta {y} LTEZero = (y ** Refl)
lteDelta {x=S x} {y=S y} (LTESucc lte) = (_ ** cong {f=S} $ snd $ lteDelta lte)

lteCutLeft : c + a `LTE` b -> a `LTE` b
lteCutLeft {c=Z}   = id
lteCutLeft {c=S k} = lteCutLeft . lteSuccLeft

multLtCross'delta : (delta : Nat ** c + delta = a) -> a * b `LT` c * d -> b `LT` d
multLtCross'delta (delta ** prf) {b} {c} =
  rewrite sym prf in
  rewrite plusCommutative c delta in
  rewrite multDistributesOverPlusLeft delta c b in
  rewrite plusSuccRightSucc (delta * b) (c * b) in
  multLtInjLeft . lteCutLeft

multLtCross : a * b `LT` c * d -> c `LTE` a -> b `LT` d
multLtCross {a} {c} abcd ca = multLtCross'delta (lteDelta ca) abcd


module Data.Group

%default total

%access public export

||| This extends 'Monoid' by defining an inverse for every element.
interface (Monoid t) => Group t where
  inverse : t -> t

||| Stream of elements starting at some given element.
generate : (Group g) => g -> Stream g
generate g1 = h where
  h = assert_total $ neutral :: map (<+> g1) h

||| (Positive) integer exponentiation.
exp : (Group g) => (n : Nat) -> g -> g
exp n g = (head . drop n) (generate g)

||| Whether a group element is idempotent
idempotent : (Eq g, Semigroup g) => g -> Bool
idempotent x = x == (x <+> x)

||| Commutator of two elements.
commutator : (Group g) => g -> g -> g
commutator a b = inverse a <+> inverse b <+> a <+> b


module MsV

import Data.Fin

%default total
%access public export

||| Encode a rational number as a fraction of a numerator and a decremental
||| denominator, thereby structural eliminating the possible of division by
||| zero.
record Frac where
  constructor Fract
  numerat : Nat
  decrDen : Nat

Fraction : Nat -> (d : Nat) -> { auto prf : IsSucc d } -> Frac
Fraction k Z {prf=ItIsSucc} impossible
Fraction k (S j) = Fract k j

Num Frac where
  (Fract n d) + (Fract m e) =
    if d == e
    then Fract (n + m) d
    else
      let d' = S d in
      let e' = S e in
      Fraction (n * e' + m * d') (d' * e')

  (Fract n d) * (Fract m e) =
    let d' = S d in
    let e' = S e in
    Fraction (n * m) (d' * e')

  fromInteger x = Fraction (fromInteger x) 1

intDiv : Frac -> Nat
intDiv (Fract n d) = intDiv' d n d where
  intDiv' : Nat -> Nat -> Nat -> Nat
  intDiv' _ Z _ = Z
  intDiv' Z n _ = n
  intDiv' origD (S n) Z = S (intDiv' origD n origD)
  intDiv' origD (S n) (S d) = intDiv' origD n d

Digit : Type
Digit = Fin 10

||| Whether we are carrying a digit during addition
data Carry = CarryOne | CarryNone

natToDigit : Nat -> Maybe Digit
natToDigit n = natToFin n 10

||| Add two fins
addFins : Fin (S n) -> Fin (S m) -> Fin (S n + S m)
addFins {n} {m} FZ x = rewrite plusCommutative (S n) (S m) in weakenN (S n) x
addFins {n} {m} x FZ = weakenN (S m) x
addFins {n = (S _)} {m = (S _)} (FS x) y@(FS _) = FS $ addFins x y

checkForCarry : Fin 20 -> (Carry, Digit)
checkForCarry FZ = (CarryNone, 0)
checkForCarry (FS FZ) = (CarryNone, 1)
checkForCarry (FS (FS FZ)) = (CarryNone, 2)
checkForCarry (FS (FS (FS FZ))) = (CarryNone, 3)
checkForCarry (FS (FS (FS (FS FZ)))) = (CarryNone, 4)
checkForCarry (FS (FS (FS (FS (FS FZ))))) = (CarryNone, 5)
checkForCarry (FS (FS (FS (FS (FS (FS FZ)))))) = (CarryNone, 6)
checkForCarry (FS (FS (FS (FS (FS (FS (FS FZ))))))) = (CarryNone, 7)
checkForCarry (FS (FS (FS (FS (FS (FS (FS (FS FZ)))))))) = (CarryNone, 8)
checkForCarry (FS (FS (FS (FS (FS (FS (FS (FS (FS x))))))))) = (CarryNone, 9)
checkForCarry (FS (FS (FS (FS (FS (FS (FS (FS (FS (FS x)))))))))) = (CarryOne, x)

addDigits : Digit -> Digit -> (Carry, Digit)
addDigits x y = checkForCarry $ addFins x y

||| Enode a rational number as either a terminating or repeating decimal
record Dec where
  constructor Decimal
  integPart : Nat
  nonrepeat : List Digit
  repeating : List Digit

infixr 5 +++

(+++) : Dec -> Dec -> Dec

-- 0.25 + 0.^3^ = 0.58^3^

fracToDec : Frac -> Dec

decToFrac : Dec -> Frac

OneNinth : Frac
OneNinth = Fraction 1 9

EightNinths : Frac
EightNinths = Fraction 8 9

NineNinths : Frac
NineNinths = Fraction 9 9

One : Dec
One = Decimal 1 [] []

DotOnesRepeating : Dec
DotOnesRepeating = Decimal 0 [] [1]

DotEightsRepeating : Dec
DotEightsRepeating = Decimal 0 [] [8]

DotNinesRepeating : Dec
DotNinesRepeating = Decimal 0 [] [9]

lemma1 : fracToDec OneNinth = DotOnesRepeating

lemma8 : fracToDec EightNinths = DotEightsRepeating

lemmaAddFrac : OneNinth + EightNinths = NineNinths

lemmaAddDec : DotOnesRepeating +++ DotEightsRepeating = DotNinesRepeating

theoremFD : fracToDec NineNinths = DotNinesRepeating

theoremDF : decToFrac DotNinesRepeating = NineNinths

||| Are the two decimals different encodings of the same number?
iso : Dec -> Dec -> Bool

theorem : iso One DotNinesRepeating = True


import Prelude
%hide Nat
%hide Maybe

data Nat = Z | S Nat

add : Nat -> Nat -> Nat
add Z m = m
add (S n) m = S (add n m)

mul : Nat -> Nat -> Nat
mul Z m = Z
mul (S n) m = add m (mul n m)

-- Extended notation for type declaration
data Nat' : Type where
  Z' : Nat'
  S' : Nat' -> Nat'

data Maybe a = Nothing | Just a

data Maybe' : Type -> Type where
  Nothing' : Maybe' a
  Just' : a -> Maybe' a

-- Expression which returns a type
f : Bool -> Type
f True = Int
f False = String

-- Dependent function
g : (n : Bool) -> f n
g True = 0
g False = "Hello"

-- Implicit arguments
myId : (a : Type) -> a -> a
myId a x = x

myId' : {a : Type} -> a -> a
myId' x = x

myId'' : a -> a
myId'' x = x

-- Useful example
data List' : Type -> Type where
  Nil' : List' a
  Cons' : a -> List' a -> List' a

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

head : Vect (S n) a -> a
head (Cons x _) = x
-- this is not mandatory
head Nil impossible

concat : Vect n a -> Vect m a -> Vect (add n m) a
concat Nil xs = xs
concat (Cons x xs) ys = Cons x (concat xs ys)

length : {n : Nat} -> Vect n a -> Nat
length {n} _ = n

-- The Identity type
--data (=) : a -> b -> Type where
--  Refl : x = x

twoPlusTwo : 2 + 2 = 4
twoPlusTwo = Refl

cong' : {f : t -> u} -> x = y -> f x = f y
cong' Refl = Refl

sym' : (x = y) -> (y = x)
sym' Refl = Refl

trans' : (x = y) -> (y = z) -> (x = z)
trans' Refl Refl = Refl

-- Proofs

total
addReducesS : (n : Nat) -> (m : Nat) -> S (add n m) = add n (S m)
addReducesS Z m = Refl
addReducesS (S k) m = cong' (addReducesS k m)

total
notEqual : 2 + 2 = 5 -> Void
notEqual Refl impossible

-- Another cool type
data Elem : List a -> a -> Type where
  Here : Elem (t :: _) t
  There : Elem ts t -> Elem (_ :: ts) t

total
emptyListIsEmpty : Elem [] _ -> Void
emptyListIsEmpty Here impossible
emptyListIsEmpty There impossible

-- Dependent Pair
data DPair' : (a : Type) -> (a -> Type) -> Type where
  MkDPair' : {P : a -> Type} -> (x : a) -> P x -> DPair' a P

-- Notation **
d : DPair Bool Main.f
d = MkDPair False "Hi"

d' : (b : Bool ** f b)
d' = (False ** "Hi")

-- Type of even numbers
T : Type
T = (x : Nat ** add x x = S (S Z))

verifiedSolution : T
verifiedSolution = (S Z ** Refl)

-- Prove no solutions exist
T2 : Type
T2 = (x : Nat ** mul x x = S (S Z))

total
t2IsFalse : T2 -> Void
t2IsFalse (Main.Z ** Refl) impossible


module ElemType

data Vect : Nat -> (ty : Type) -> Type where
     Nil : Vect Z ty
     (::) : ty -> Vect n ty -> Vect (S n) ty

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

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

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

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

-- Exercise 9.1 # 1
data LElem : a -> List a -> Type where
     LHere : LElem x (x :: xs)
     LThere : (later : LElem x xs) -> LElem x (y :: xs)

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

isLastNil : Last [] value -> Void
isLastNil LastOne impossible
isLastNil (LastCons _) impossible

isNotLast : (contra : Last xs value -> Void) -> (notFinalprf : (xs = []) -> Void) -> Last (x :: xs) value -> Void
isNotLast contra notFinalprf LastOne = notFinalprf Refl
isNotLast contra notFinalprf (LastCons prf) = contra prf

isLastLemma : (eqValPrf : x = value) -> (finalValPrf : xs = []) -> Last (x :: xs) value
isLastLemma Refl Refl = LastOne

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No isLastNil
isLast (x :: xs) value = case decEq xs [] of
                              (Yes finalValPrf) => case decEq x value of
                                                (Yes eqValPrf) => Yes (isLastLemma eqValPrf finalValPrf)
                                                -- Or:
                                                -- (Yes eqValPrf) => Yes (rewrite eqValPrf in rewrite finalValPrf in LastOne)
                                                (No contra) => ?adfasfasd_3
                              (No notFinalprf) => case isLast xs value of
                                            (Yes prf) => Yes (LastCons prf)
                                            (No contra) => No (isNotLast contra notFinalprf)


module Mergesort

import Data.Vect

import Lecture.Evens

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

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

insertend : (x:elem)->Vect n elem->Vect (S n) elem
insertend x [] = [x]
insertend x (y :: xs) = y::(insertend x xs)

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

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

--Defined in class. This is used to split the input vector into two parts.
--The length of the first part is halfRoof n.
halfRoof: Nat -> Nat
halfRoof n = case (nOrSnEven n) of
                  (Left nEven) => half n nEven
                  (Right snEven) => half (S n) snEven

--function that returns (n - halfRoof n) i.e. the length of the second part
--after input vector is split.
halfRoofComplement : Nat -> Nat
halfRoofComplement Z = Z
halfRoofComplement (S k) = halfRoof k

--function that splits a vector into two parts at its mid point.
--if n is even, it gives two halves of length n/2 each.
--if n is odd, the first half is (n+1)/2 length and the second half is
--(n-1)/2 length
halfVect : Vect n elem -> ((Vect (halfRoof n) elem), (Vect (halfRoofComplement n) elem))
halfVect {n} xs = ((Vecttake (halfRoof n) xs), (Vecttakefromlast (halfRoofComplement n) xs))

--this function is to cast a vector from one type to another
sillycast: (v1:(Vect ((S k) + j) elem)) ->( Vect (k+ (S j)) elem)
sillycast {k} {j} v1 = (Vecttake k v1) ++ (Vecttakefromlast (S j) v1)

--function to cast a vector from one type to another.
--makes the vector obtained on applying merge to two halves same as
--the type of the input vector.
sillycast2 : (Vect ((halfRoof n) + (halfRoofComplement n)) elem) -> Vect n elem
sillycast2 {n} xs = Vecttake n xs

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

--The mergesort function
mergesort :Ord elem => Vect n elem -> Vect n elem
mergesort [] = []
mergesort [x] = [x]
mergesort xs = sillycast2 (merge1 (mergesort (fst(halfVect xs))) (mergesort (snd(halfVect xs))))


--------------------------------------------------------------------------------
-- This file is here so GitHub thinks this is an Idris repo :D
--------------------------------------------------------------------------------

module Prelude.Nat

import Builtins

import Prelude.Algebra
import Prelude.Basics
import Prelude.Bool
import Prelude.Cast
import Prelude.Interfaces
import Prelude.Uninhabited

%access public export
%default total

||| Natural numbers: unbounded, unsigned integers which can be pattern
||| matched.
%elim data Nat =
  ||| Zero
  Z |
  ||| Successor
  S Nat

-- name hints for interactive editing
%name Nat k,j,i,n,m

Uninhabited (Z = S n) where
  uninhabited Refl impossible

--------------------------------------------------------------------------------
-- Syntactic tests
--------------------------------------------------------------------------------

total isZero : Nat -> Bool
isZero Z     = True
isZero (S n) = False

total isSucc : Nat -> Bool
isSucc Z     = False
isSucc (S n) = True

--------------------------------------------------------------------------------
-- Basic arithmetic functions
--------------------------------------------------------------------------------

||| Add two natural numbers.
||| @ n the number to case-split on
||| @ m the other number
total plus : (n, m : Nat) -> Nat
plus Z right        = right
plus (S left) right = S (plus left right)

||| Multiply natural numbers
total mult : Nat -> Nat -> Nat
mult Z right        = Z
mult (S left) right = plus right $ mult left right

||| Convert an Integer to a Nat, mapping negative numbers to 0
fromIntegerNat : Integer -> Nat
fromIntegerNat 0 = Z
fromIntegerNat n =
  if (n > 0) then
    S (fromIntegerNat (assert_smaller n (n - 1)))
  else
    Z

||| Convert a Nat to an Integer
toIntegerNat : Nat -> Integer
toIntegerNat Z = 0
toIntegerNat (S k) = 1 + toIntegerNat k

||| Subtract natural numbers. If the second number is larger than the first, return 0.
total minus : Nat -> Nat -> Nat
minus Z        right     = Z
minus left     Z         = left
minus (S left) (S right) = minus left right

||| Exponentiation of natural numbers
total power : Nat -> Nat -> Nat
power base Z       = S Z
power base (S exp) = mult base $ power base exp

hyper : Nat -> Nat -> Nat -> Nat
hyper Z        a b      = S b
hyper (S Z)    a Z      = a
hyper (S(S Z)) a Z      = Z
hyper n        a Z      = S Z
hyper (S pn)   a (S pb) = hyper pn a (hyper (S pn) a pb)

--------------------------------------------------------------------------------
-- Comparisons
--------------------------------------------------------------------------------

||| Proofs that `n` or `m` is not equal to Z
data NotBothZero : (n, m : Nat) -> Type where
  LeftIsNotZero  : NotBothZero (S n) m
  RightIsNotZero : NotBothZero n     (S m)

||| Proofs that `n` is less than or equal to `m`
||| @ n the smaller number
||| @ m the larger number
data LTE  : (n, m : Nat) -> Type where
  ||| Zero is the smallest Nat
  LTEZero : LTE Z    right
  ||| If n <= m, then n + 1 <= m + 1
  LTESucc : LTE left right -> LTE (S left) (S right)

Uninhabited (LTE (S n) Z) where
  uninhabited LTEZero impossible

||| Greater than or equal to
total GTE : Nat -> Nat -> Type
GTE left right = LTE right left

||| Strict less than
total LT : Nat -> Nat -> Type
LT left right = LTE (S left) right

||| Strict greater than
total GT : Nat -> Nat -> Type
GT left right = LT right left

||| A successor is never less than or equal zero
succNotLTEzero : Not (S m `LTE` Z)
succNotLTEzero LTEZero impossible

||| If two numbers are ordered, their predecessors are too
fromLteSucc : (S m `LTE` S n) -> (m `LTE` n)
fromLteSucc (LTESucc x) = x

||| A decision procedure for `LTE`
isLTE : (m, n : Nat) -> Dec (m `LTE` n)
isLTE Z n = Yes LTEZero
isLTE (S k) Z = No succNotLTEzero
isLTE (S k) (S j) with (isLTE k j)
  isLTE (S k) (S j) | (Yes prf) = Yes (LTESucc prf)
  isLTE (S k) (S j) | (No contra) = No (contra . fromLteSucc)

||| `LTE` is reflexive.
lteRefl : LTE n n
lteRefl {n = Z}   = LTEZero
lteRefl {n = S k} = LTESucc lteRefl

||| n < m implies n < m + 1
lteSuccRight : LTE n m -> LTE n (S m)
lteSuccRight LTEZero     = LTEZero
lteSuccRight (LTESucc x) = LTESucc (lteSuccRight x)

||| n + 1 < m implies n < m
lteSuccLeft : LTE (S n) m -> LTE n m
lteSuccLeft (LTESucc x) = lteSuccRight x

||| `LTE` is transitive
lteTransitive : LTE n m -> LTE m p -> LTE n p
lteTransitive LTEZero y = LTEZero
lteTransitive (LTESucc x) (LTESucc y) = LTESucc (lteTransitive x y)

lteAddRight : (n : Nat) -> LTE n (plus n m)
lteAddRight Z = LTEZero
lteAddRight (S k) = LTESucc (lteAddRight k)

||| Boolean test than one Nat is less than or equal to another
total lte : Nat -> Nat -> Bool
lte Z        right     = True
lte left     Z         = False
lte (S left) (S right) = lte left right

||| Boolean test than one Nat is greater than or equal to another
total gte : Nat -> Nat -> Bool
gte left right = lte right left

||| Boolean test than one Nat is strictly less than another
total lt : Nat -> Nat -> Bool
lt left right = lte (S left) right

||| Boolean test than one Nat is strictly greater than another
total gt : Nat -> Nat -> Bool
gt left right = lt right left

||| Find the least of two natural numbers
total minimum : Nat -> Nat -> Nat
minimum Z m = Z
minimum (S n) Z = Z
minimum (S n) (S m) = S (minimum n m)

||| Find the greatest of two natural numbers
total maximum : Nat -> Nat -> Nat
maximum Z m = m
maximum (S n) Z = S n
maximum (S n) (S m) = S (maximum n m)

||| Cast Nat to Int
||| Note that this can overflow
toIntNat : Nat -> Int
toIntNat n = prim__truncBigInt_Int (toIntegerNat n)

(-) : (m : Nat) -> (n : Nat) -> {auto smaller : LTE n m} -> Nat
(-) m n {smaller} = minus m n

--------------------------------------------------------------------------------
-- Interface implementations
--------------------------------------------------------------------------------

Eq Nat where
  Z == Z         = True
  (S l) == (S r) = l == r
  _ == _         = False

Cast Nat Integer where
  cast = toIntegerNat

Ord Nat where
  compare Z Z         = EQ
  compare Z (S k)     = LT
  compare (S k) Z     = GT
  compare (S x) (S y) = compare x y

Num Nat where
  (+) = plus
  (*) = mult

  fromInteger = fromIntegerNat

MinBound Nat where
  minBound = Z

||| Casts negative `Integers` to 0.
Cast Integer Nat where
  cast = fromInteger

Cast String Nat where
    cast str = cast (the Integer (cast str))

||| A wrapper for Nat that specifies the semigroup and monoid implementations that use (*)
record Multiplicative where
  constructor GetMultiplicative
  _ : Nat

||| A wrapper for Nat that specifies the semigroup and monoid implementations that use (+)
record Additive where
  constructor GetAdditive
  _ : Nat

Semigroup Multiplicative where
  (<+>) left right = GetMultiplicative $ left' * right'
    where
      left'  : Nat
      left'  =
       case left of
          GetMultiplicative m => m

      right' : Nat
      right' =
        case right of
          GetMultiplicative m => m

Semigroup Additive where
  left <+> right = GetAdditive $ left' + right'
    where
      left'  : Nat
      left'  =
        case left of
          GetAdditive m => m

      right' : Nat
      right' =
        case right of
          GetAdditive m => m

Monoid Multiplicative where
  neutral = GetMultiplicative $ S Z

Monoid Additive where
  neutral = GetAdditive Z

||| Casts negative `Ints` to 0.
Cast Int Nat where
  cast i = fromInteger (cast i)

Cast Nat Int where
  cast = toIntNat

Cast Nat Double where
  cast = cast . toIntegerNat

--------------------------------------------------------------------------------
-- Auxilliary notions
--------------------------------------------------------------------------------

||| The predecessor of a natural number. `pred Z` is `Z`.
total pred : Nat -> Nat
pred Z     = Z
pred (S n) = n

--------------------------------------------------------------------------------
-- Fibonacci and factorial
--------------------------------------------------------------------------------

||| Fibonacci numbers
total fib : Nat -> Nat
fib Z         = Z
fib (S Z)     = S Z
fib (S (S n)) = fib (S n) + fib n

||| Factorial function
total fact : Nat -> Nat
fact Z     = S Z
fact (S n) = (S n) * fact n

--------------------------------------------------------------------------------
-- Division and modulus
--------------------------------------------------------------------------------

||| The proof that no successor of a natural number can be zero.
|||
||| ```idris example
||| modNatNZ 10 3 SIsNotZ
||| ```
SIsNotZ : {x: Nat} -> (S x = Z) -> Void
SIsNotZ Refl impossible

||| Modulus function where the divisor is not zero.
|||
||| ```idris example
||| modNatNZ 100 2 SIsNotZ
||| ```
modNatNZ : Nat -> (y: Nat) -> Not (y = Z) -> Nat
modNatNZ left Z         p = void (p Refl)
modNatNZ left (S right) _ = mod' left left right
  where
    total mod' : Nat -> Nat -> Nat -> Nat
    mod' Z        centre right = centre
    mod' (S left) centre right =
      if lte centre right then
        centre
      else
        mod' left (minus centre (S right)) right

partial
modNat : Nat -> Nat -> Nat
modNat left (S right) = modNatNZ left (S right) SIsNotZ

||| Division where the divisor is not zero.
|||
||| ```idris example
||| divNatNZ 100 2 SIsNotZ
||| ```
divNatNZ : Nat -> (y: Nat) -> Not (y = Z) -> Nat
divNatNZ left Z         p = void (p Refl)
divNatNZ left (S right) _ = div' left left right
  where
    total div' : Nat -> Nat -> Nat -> Nat
    div' Z        centre right = Z
    div' (S left) centre right =
      if lte centre right then
        Z
      else
        S (div' left (minus centre (S right)) right)

partial
divNat : Nat -> Nat -> Nat
divNat left (S right) = divNatNZ left (S right) SIsNotZ

divCeilNZ : Nat -> (y: Nat) -> Not (y = 0) -> Nat
divCeilNZ x y p = case (modNatNZ x y p) of
  Z   => divNatNZ x y p
  S _ => S (divNatNZ x y p)

partial
divCeil : Nat -> Nat -> Nat
divCeil x (S y) = divCeilNZ x (S y) SIsNotZ

partial
Integral Nat where
  div = divNat
  mod = modNat

log2NZ : (x: Nat) -> Not (x = Z) -> Nat
log2NZ Z         p = void (p Refl)
log2NZ (S Z)     _ = Z
log2NZ (S (S n)) _ = S (log2NZ (assert_smaller (S (S n)) (S (divNatNZ n 2 SIsNotZ))) SIsNotZ)

partial
log2 : Nat -> Nat
log2 (S n) = log2NZ (S n) SIsNotZ

--------------------------------------------------------------------------------
-- GCD and LCM
--------------------------------------------------------------------------------
gcd : (a: Nat) -> (b: Nat) -> .{auto ok: NotBothZero a b} -> Nat
gcd a Z     = a
gcd Z b     = b
gcd a (S b) = assert_total $ gcd (S b) (modNatNZ a (S b) SIsNotZ)

lcm : Nat -> Nat -> Nat
lcm _ Z     = Z
lcm Z _     = Z
lcm a (S b) = assert_total $ divNat (a * (S b)) (gcd a (S b))

--------------------------------------------------------------------------------
-- An informative comparison view
--------------------------------------------------------------------------------
data CmpNat : Nat -> Nat -> Type where
     CmpLT : (y : _) -> CmpNat x (x + S y)
     CmpEQ : CmpNat x x
     CmpGT : (x : _) -> CmpNat (y + S x) y

total cmp : (x, y : Nat) -> CmpNat x y
cmp Z Z     = CmpEQ
cmp Z (S k) = CmpLT _
cmp (S k) Z = CmpGT _
cmp (S x) (S y) with (cmp x y)
  cmp (S x) (S (x + (S k))) | CmpLT k = CmpLT k
  cmp (S x) (S x)           | CmpEQ   = CmpEQ
  cmp (S (y + (S k))) (S y) | CmpGT k = CmpGT k

--------------------------------------------------------------------------------
-- Properties
--------------------------------------------------------------------------------

-- Succ

||| S preserves equality
total eqSucc : (left : Nat) -> (right : Nat) -> (p : left = right) ->
  S left = S right
eqSucc left _ Refl = Refl

||| S is injective
total succInjective : (left : Nat) -> (right : Nat) -> (p : S left = S right) ->
  left = right
succInjective left _ Refl = Refl

-- Plus
total plusZeroLeftNeutral : (right : Nat) -> 0 + right = right
plusZeroLeftNeutral right = Refl

total plusZeroRightNeutral : (left : Nat) -> left + 0 = left
plusZeroRightNeutral Z     = Refl
plusZeroRightNeutral (S n) =
  let inductiveHypothesis = plusZeroRightNeutral n in
    rewrite inductiveHypothesis in Refl

total plusSuccRightSucc : (left : Nat) -> (right : Nat) ->
  S (left + right) = left + (S right)
plusSuccRightSucc Z right        = Refl
plusSuccRightSucc (S left) right =
  let inductiveHypothesis = plusSuccRightSucc left right in
    rewrite inductiveHypothesis in Refl

total plusCommutative : (left : Nat) -> (right : Nat) ->
  left + right = right + left
plusCommutative Z        right = rewrite plusZeroRightNeutral right in Refl
plusCommutative (S left) right =
  let inductiveHypothesis = plusCommutative left right in
    rewrite inductiveHypothesis in
      rewrite plusSuccRightSucc right left in Refl

total plusAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->
  left + (centre + right) = (left + centre) + right
plusAssociative Z        centre right = Refl
plusAssociative (S left) centre right =
  let inductiveHypothesis = plusAssociative left centre right in
    rewrite inductiveHypothesis in Refl

total plusConstantRight : (left : Nat) -> (right : Nat) -> (c : Nat) ->
  (p : left = right) -> left + c = right + c
plusConstantRight left _ c Refl = Refl

total plusConstantLeft : (left : Nat) -> (right : Nat) -> (c : Nat) ->
  (p : left = right) -> c + left = c + right
plusConstantLeft left _ c Refl = Refl

total plusOneSucc : (right : Nat) -> 1 + right = S right
plusOneSucc n = Refl

total plusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) ->
  (p : left + right = left + right') -> right = right'
plusLeftCancel Z        right right' p = p
plusLeftCancel (S left) right right' p =
  let inductiveHypothesis = plusLeftCancel left right right' in
    inductiveHypothesis (succInjective _ _ p)

total plusRightCancel : (left : Nat) -> (left' : Nat) -> (right : Nat) ->
  (p : left + right = left' + right) -> left = left'
plusRightCancel left left' Z         p = rewrite sym (plusZeroRightNeutral left) in
                                         rewrite sym (plusZeroRightNeutral left') in
                                                 p
plusRightCancel left left' (S right) p =
  plusRightCancel left left' right
    (succInjective _ _ (rewrite plusSuccRightSucc left right in
                        rewrite plusSuccRightSucc left' right in p))

total plusLeftLeftRightZero : (left : Nat) -> (right : Nat) ->
  (p : left + right = left) -> right = Z
plusLeftLeftRightZero Z        right p = p
plusLeftLeftRightZero (S left) right p =
  plusLeftLeftRightZero left right (succInjective _ _ p)

-- Mult
total multZeroLeftZero : (right : Nat) -> Z * right = Z
multZeroLeftZero right = Refl

total multZeroRightZero : (left : Nat) -> left * Z = Z
multZeroRightZero Z        = Refl
multZeroRightZero (S left) = multZeroRightZero left

total multRightSuccPlus : (left : Nat) -> (right : Nat) ->
  left * (S right) = left + (left * right)
multRightSuccPlus Z        right = Refl
multRightSuccPlus (S left) right =
  let inductiveHypothesis = multRightSuccPlus left right in
    rewrite inductiveHypothesis in
    rewrite plusAssociative left right (mult left right) in
    rewrite plusAssociative right left (mult left right) in
    rewrite plusCommutative right left in
            Refl

total multLeftSuccPlus : (left : Nat) -> (right : Nat) ->
  (S left) * right = right + (left * right)
multLeftSuccPlus left right = Refl

total multCommutative : (left : Nat) -> (right : Nat) ->
  left * right = right * left
multCommutative Z right        = rewrite multZeroRightZero right in Refl
multCommutative (S left) right =
  let inductiveHypothesis = multCommutative left right in
      rewrite inductiveHypothesis in
      rewrite multRightSuccPlus right left in
              Refl

total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->
  left * (centre + right) = (left * centre) + (left * right)
multDistributesOverPlusRight Z        centre right = Refl
multDistributesOverPlusRight (S left) centre right =
  let inductiveHypothesis = multDistributesOverPlusRight left centre right in
    rewrite inductiveHypothesis in
    rewrite plusAssociative (plus centre (mult left centre)) right (mult left right) in
    rewrite sym (plusAssociative centre (mult left centre) right) in
    rewrite plusCommutative (mult left centre) right in
    rewrite plusAssociative centre right (mult left centre) in
    rewrite plusAssociative (plus centre right) (mult left centre) (mult left right) in
            Refl

total multDistributesOverPlusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) ->
  (left + centre) * right = (left * right) + (centre * right)
multDistributesOverPlusLeft Z        centre right = Refl
multDistributesOverPlusLeft (S left) centre right =
  let inductiveHypothesis = multDistributesOverPlusLeft left centre right in
    rewrite inductiveHypothesis in
    rewrite plusAssociative right (mult left right) (mult centre right) in
            Refl

total multAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->
  left * (centre * right) = (left * centre) * right
multAssociative Z        centre right = Refl
multAssociative (S left) centre right =
  let inductiveHypothesis = multAssociative left centre right in
    rewrite inductiveHypothesis in
    rewrite multDistributesOverPlusLeft centre (mult left centre) right in
            Refl

total multOneLeftNeutral : (right : Nat) -> 1 * right = right
multOneLeftNeutral Z         = Refl
multOneLeftNeutral (S right) =
  let inductiveHypothesis = multOneLeftNeutral right in
    rewrite inductiveHypothesis in
            Refl

total multOneRightNeutral : (left : Nat) -> left * 1 = left
multOneRightNeutral Z        = Refl
multOneRightNeutral (S left) =
  let inductiveHypothesis = multOneRightNeutral left in
    rewrite inductiveHypothesis in
            Refl

-- Minus
total minusSuccSucc : (left : Nat) -> (right : Nat) ->
  minus (S left) (S right) = minus left right
minusSuccSucc left right = Refl

total minusZeroLeft : (right : Nat) -> minus 0 right = Z
minusZeroLeft right = Refl

total minusZeroRight : (left : Nat) -> minus left 0 = left
minusZeroRight Z        = Refl
minusZeroRight (S left) = Refl

total minusZeroN : (n : Nat) -> Z = minus n n
minusZeroN Z     = Refl
minusZeroN (S n) = minusZeroN n

total minusOneSuccN : (n : Nat) -> S Z = minus (S n) n
minusOneSuccN Z     = Refl
minusOneSuccN (S n) = minusOneSuccN n

total minusSuccOne : (n : Nat) -> minus (S n) 1 = n
minusSuccOne Z     = Refl
minusSuccOne (S n) = Refl

total minusPlusZero : (n : Nat) -> (m : Nat) -> minus n (n + m) = Z
minusPlusZero Z     m = Refl
minusPlusZero (S n) m = minusPlusZero n m

total minusMinusMinusPlus : (left : Nat) -> (centre : Nat) -> (right : Nat) ->
  minus (minus left centre) right = minus left (centre + right)
minusMinusMinusPlus Z        Z          right = Refl
minusMinusMinusPlus (S left) Z          right = Refl
minusMinusMinusPlus Z        (S centre) right = Refl
minusMinusMinusPlus (S left) (S centre) right =
  let inductiveHypothesis = minusMinusMinusPlus left centre right in
    rewrite inductiveHypothesis in
            Refl

total plusMinusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) ->
  minus (left + right) (left + right') = minus right right'
plusMinusLeftCancel Z right right'        = Refl
plusMinusLeftCancel (S left) right right' =
  let inductiveHypothesis = plusMinusLeftCancel left right right' in
    rewrite inductiveHypothesis in
            Refl

total multDistributesOverMinusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) ->
  (minus left centre) * right = minus (left * right) (centre * right)
multDistributesOverMinusLeft Z        Z          right = Refl
multDistributesOverMinusLeft (S left) Z          right =
    rewrite (minusZeroRight (plus right (mult left right))) in Refl
multDistributesOverMinusLeft Z        (S centre) right = Refl
multDistributesOverMinusLeft (S left) (S centre) right =
  let inductiveHypothesis = multDistributesOverMinusLeft left centre right in
    rewrite inductiveHypothesis in
    rewrite plusMinusLeftCancel right (mult left right) (mult centre right) in
            Refl

total multDistributesOverMinusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->
  left * (minus centre right) = minus (left * centre) (left * right)
multDistributesOverMinusRight left centre right =
    rewrite multCommutative left (minus centre right) in
    rewrite multDistributesOverMinusLeft centre right left in
    rewrite multCommutative centre left in
    rewrite multCommutative right left in
            Refl

-- Power
total powerSuccPowerLeft : (base : Nat) -> (exp : Nat) -> power base (S exp) =
  base * (power base exp)
powerSuccPowerLeft base exp = Refl

total multPowerPowerPlus : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->
  (power base exp) * (power base exp') = power base (exp + exp')
multPowerPowerPlus base Z       exp' =
    rewrite sym (plusZeroRightNeutral (power base exp')) in Refl
multPowerPowerPlus base (S exp) exp' =
  let inductiveHypothesis = multPowerPowerPlus base exp exp' in
    rewrite sym inductiveHypothesis in
    rewrite sym (multAssociative base (power base exp) (power base exp')) in
            Refl

total powerZeroOne : (base : Nat) -> power base 0 = S Z
powerZeroOne base = Refl

total powerOneNeutral : (base : Nat) -> power base 1 = base
powerOneNeutral Z        = Refl
powerOneNeutral (S base) =
  let inductiveHypothesis = powerOneNeutral base in
    rewrite inductiveHypothesis in Refl

total powerOneSuccOne : (exp : Nat) -> power 1 exp = S Z
powerOneSuccOne Z       = Refl
powerOneSuccOne (S exp) =
  let inductiveHypothesis = powerOneSuccOne exp in
    rewrite inductiveHypothesis in Refl

total powerSuccSuccMult : (base : Nat) -> power base 2 = mult base base
powerSuccSuccMult Z        = Refl
powerSuccSuccMult (S base) = rewrite multOneRightNeutral base in Refl

total powerPowerMultPower : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->
  power (power base exp) exp' = power base (exp * exp')
powerPowerMultPower base exp Z        = rewrite multZeroRightZero exp in Refl
powerPowerMultPower base exp (S exp') =
  let inductiveHypothesis = powerPowerMultPower base exp exp' in
    rewrite inductiveHypothesis in
    rewrite multRightSuccPlus exp exp' in
    rewrite sym (multPowerPowerPlus base exp (mult exp exp')) in
            Refl

-- Pred
total predSucc : (n : Nat) -> pred (S n) = n
predSucc n = Refl

total minusSuccPred : (left : Nat) -> (right : Nat) ->
  minus left (S right) = pred (minus left right)
minusSuccPred Z        right = Refl
minusSuccPred (S left) Z =
    rewrite minusZeroRight left in Refl
minusSuccPred (S left) (S right) =
  let inductiveHypothesis = minusSuccPred left right in
    rewrite inductiveHypothesis in Refl

-- ifThenElse
total ifThenElseSuccSucc : (cond : Bool) -> (t : Nat) -> (f : Nat) ->
  S (ifThenElse cond t f) = ifThenElse cond (S t) (S f)
ifThenElseSuccSucc True  t f = Refl
ifThenElseSuccSucc False t f = Refl

total ifThenElsePlusPlusLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) ->
  left + (ifThenElse cond t f) = ifThenElse cond (left + t) (left + f)
ifThenElsePlusPlusLeft True  left t f = Refl
ifThenElsePlusPlusLeft False left t f = Refl

total ifThenElsePlusPlusRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) ->
  (ifThenElse cond t f) + right = ifThenElse cond (t + right) (f + right)
ifThenElsePlusPlusRight True  right t f = Refl
ifThenElsePlusPlusRight False right t f = Refl

total ifThenElseMultMultLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) ->
  left * (ifThenElse cond t f) = ifThenElse cond (left * t) (left * f)
ifThenElseMultMultLeft True  left t f = Refl
ifThenElseMultMultLeft False left t f = Refl

total ifThenElseMultMultRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) ->
  (ifThenElse cond t f) * right = ifThenElse cond (t * right) (f * right)
ifThenElseMultMultRight True  right t f = Refl
ifThenElseMultMultRight False right t f = Refl

-- Orders
total lteNTrue : (n : Nat) -> lte n n = True
lteNTrue Z     = Refl
lteNTrue (S n) = lteNTrue n

total LTESuccZeroFalse : (n : Nat) -> lte (S n) Z = False
LTESuccZeroFalse Z     = Refl
LTESuccZeroFalse (S n) = Refl

-- Minimum and maximum
total maximumAssociative : (l,c,r : Nat) -> maximum l (maximum c r) = maximum (maximum l c) r
maximumAssociative Z c r = Refl
maximumAssociative (S k) Z r = Refl
maximumAssociative (S k) (S j) Z = Refl
maximumAssociative (S k) (S j) (S i) = rewrite maximumAssociative k j i in Refl

total maximumCommutative : (l, r : Nat) -> maximum l r = maximum r l
maximumCommutative Z Z = Refl
maximumCommutative Z (S k) = Refl
maximumCommutative (S k) Z = Refl
maximumCommutative (S k) (S j) = rewrite maximumCommutative k j in Refl

total maximumIdempotent : (n : Nat) -> maximum n n = n
maximumIdempotent Z = Refl
maximumIdempotent (S k) = cong (maximumIdempotent k)

total minimumAssociative : (l,c,r : Nat) -> minimum l (minimum c r) = minimum (minimum l c) r
minimumAssociative Z c r = Refl
minimumAssociative (S k) Z r = Refl
minimumAssociative (S k) (S j) Z = Refl
minimumAssociative (S k) (S j) (S i) = rewrite minimumAssociative k j i in Refl

total minimumCommutative : (l, r : Nat) -> minimum l r = minimum r l
minimumCommutative Z Z = Refl
minimumCommutative Z (S k) = Refl
minimumCommutative (S k) Z = Refl
minimumCommutative (S k) (S j) = rewrite minimumCommutative k j in Refl

total minimumIdempotent : (n : Nat) -> minimum n n = n
minimumIdempotent Z = Refl
minimumIdempotent (S k) = cong (minimumIdempotent k)

total minimumZeroZeroRight : (right : Nat) -> minimum 0 right = Z
minimumZeroZeroRight Z = Refl
minimumZeroZeroRight (S right) = minimumZeroZeroRight right

total minimumZeroZeroLeft : (left : Nat) -> minimum left 0 = Z
minimumZeroZeroLeft Z        = Refl
minimumZeroZeroLeft (S left) = Refl

total minimumSuccSucc : (left : Nat) -> (right : Nat) ->
  minimum (S left) (S right) = S (minimum left right)
minimumSuccSucc Z        Z         = Refl
minimumSuccSucc (S left) Z         = Refl
minimumSuccSucc Z        (S right) = Refl
minimumSuccSucc (S left) (S right) = Refl

total maximumZeroNRight : (right : Nat) -> maximum Z right = right
maximumZeroNRight Z         = Refl
maximumZeroNRight (S right) = Refl

total maximumZeroNLeft : (left : Nat) -> maximum left Z = left
maximumZeroNLeft Z        = Refl
maximumZeroNLeft (S left) = Refl

total maximumSuccSucc : (left : Nat) -> (right : Nat) ->
  S (maximum left right) = maximum (S left) (S right)
maximumSuccSucc Z        Z         = Refl
maximumSuccSucc (S left) Z         = Refl
maximumSuccSucc Z        (S right) = Refl
maximumSuccSucc (S left) (S right) = Refl

total sucMaxL : (l : Nat) -> maximum (S l) l = (S l)
sucMaxL Z = Refl
sucMaxL (S l) = cong (sucMaxL l)

total sucMaxR : (l : Nat) -> maximum l (S l) = (S l)
sucMaxR Z = Refl
sucMaxR (S l) = cong (sucMaxR l)

total sucMinL : (l : Nat) -> minimum (S l) l = l
sucMinL Z = Refl
sucMinL (S l) = cong (sucMinL l)

total sucMinR : (l : Nat) -> minimum l (S l) = l
sucMinR Z = Refl
sucMinR (S l) = cong (sucMinR l)


module Rings

import Monoid
import Group

%access public export

||| Distributive Law
total
IsDistributive : (typ : Type) -> ((+) : typ -> typ -> typ)
                  -> ((*) : typ -> typ -> typ) -> Type
IsDistributive typ (+) (*) = (a,b,c : typ) -> ( (a*(b + c) = (a*b) + (a*c)), ((b + c)*a = (b*a) + (c*a)) )

||| The type of proofs that a given type is a ring
total
IsRing : (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> Type
IsRing ring (+) (*) = (IsAbelianGrp ring (+), (Associative ring (*), IsDistributive ring (+) (*)))

||| The type of proofs that a given type is a commutative ring
total
IsCommRing : (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> Type
IsCommRing ring (+) (*) = (IsRing ring (+) (*) , Commutative ring (*))

||| Data type for rings
data Ring: (ring: Type) -> Type where
  MkRing: (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> IsRing ring (+) (*) -> Ring ring

||| Data type for commutative rings
data CRing: (ring: Type) -> Type where
  MkCRing: (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> IsCommRing ring (+) (*) -> CRing ring

|||A function that outputs the addition operation of a ring structure
Ring_Add: (ring: Type) -> Ring ring -> ring -> ring -> ring
Ring_Add ring (MkRing ring (+) (*) x) y z = y+z

|||A function that outputs the multiplication operation of a ring structure
Ring_Mult: (ring: Type) -> Ring ring -> ring -> ring -> ring
Ring_Mult ring (MkRing ring (+) (*) x) y z = y*z

||| Gives the additive identity of the ring
total
RingAdditive_id : (ring : Type) -> (pfr: Ring ring) -> (IdentityExists ring (Ring_Add ring pfr))
RingAdditive_id ring (MkRing ring (+) (*) ((pfGrp,pfAb), pfElse)) = Group_id ring (+) pfGrp

||| Non Zero elements in a ring
total
Ring_NonZero_Elements : (ring : Type) -> Ring ring -> Type
Ring_NonZero_Elements ring pfr = (a : ring ** ((a = e) -> Void)) where
                                             e = fst (RingAdditive_id ring pfr)

||| Type of rings with identity
total
IsRing_with_identity : (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> Type
IsRing_with_identity ring (+) (*) = (IsAbelianGrp ring (+), (IsMonoid ring (*), IsDistributive ring (+) (*)))

||| Useful rings - i.e commutative rings with identity
total
IsUsefulRing :  (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> Type
IsUsefulRing ring (+) (*) = (IsRing_with_identity ring (+) (*), IsCommRing ring (+) (*))

|||Data type for rings with identity
data Ring_with_identity: (ring: Type) -> Type where
  MkRing_with_identity: (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> IsRing_with_identity ring (+) (*) -> Ring_with_identity ring

|||Dat atypes for Useful rings
data URing: (ring: Type) -> Type where
  MkURing: (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> IsUsefulRing ring (+) (*) -> URing ring

||| A function that demonstrates that every Useful ring is commutative
total
URingisCRing: (ring: Type) -> URing ring -> CRing ring
URingisCRing ring (MkURing ring ((+)) ((*)) (a, b)) = MkCRing ring (+) (*) b

|||A function that demonstrates that every commutative ring is a ring
total
CRingisRing: (ring: Type) -> CRing ring -> Ring ring
CRingisRing ring (MkCRing ring ((+)) ((*)) (a, b)) = MkRing ring (+) (*) a

||| A function that demonstrates that every Useful ring is commutative
total
URingisRing_with_identity: (ring: Type) -> URing ring -> Ring_with_identity ring
URingisRing_with_identity ring (MkURing ring ((+)) ((*)) (a, b)) = MkRing_with_identity ring (+) (*) a

||| A function that demonstrates that every ring with identity is a ring
total
Ring_with_identity_isRing: (ring: Type) -> Ring_with_identity ring -> Ring ring
Ring_with_identity_isRing ring (MkRing_with_identity ring ((+)) ((*)) (a, b)) = MkRing ring (+) (*) (a, ((Basics.fst (Basics.fst b)), (Basics.snd b)))

|||A function that outputs the addition operation of a ring structure (with identity) - seemed more convenient than proving that the addition operation arising from the Ring_Add function is the right one
IRing_Add: (ring: Type) -> Ring_with_identity ring -> ring -> ring -> ring
IRing_Add ring (MkRing_with_identity ring (+) (*) x) y z = y +z

|||A function that outputs the multiplication operation of a ring structure (with identity)
IRing_Mult: (ring: Type) -> Ring_with_identity ring -> ring -> ring -> ring
IRing_Mult ring (MkRing_with_identity ring (+) (*) x) y z = y*z

Ring_Mult_identity: (ring: Type) -> (pfr: Ring_with_identity ring) -> DPair ring (\e => IsIdentity ring (IRing_Mult ring pfr) e)
Ring_Mult_identity ring (MkRing_with_identity ring (+) (*) x) = Basics.snd (Basics.fst (Basics.snd x))

||| Rings that have zero divisors
total
Ring_with_zero_divisor : (ring : Type) -> Ring ring -> Type
Ring_with_zero_divisor ring (MkRing ring (+) (*) pfRing) = (a : ring ** (b : ring ** Either (a*b = e) (b*a = e))) where
                                  e = DPair.fst (RingAdditive_id ring (MkRing ring (+) (*) pfRing))

||| The type of proofs that a given type is an Integral Domain
total
IsIntegralDomain : (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> Type
IsIntegralDomain ring (+) (*) = (pfRing : IsUsefulRing ring (+) (*) ** (((a : ring) -> (b : ring) -> (a*b = fst (RingAdditive_id ring (MkRing ring (+) (*) (fst (snd pfRing))) )) -> (Either (a = fst (RingAdditive_id ring (MkRing ring (+) (*) (fst (snd pfRing))) )) (b = fst (RingAdditive_id  ring (MkRing ring (+) (*) (fst (snd pfRing))) )) ) )) )

||| Data type for integral domains
data IntegralDomain: (ring: Type) -> Type where
  MkIntegralDomain: (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> IsIntegralDomain ring (+) (*) -> IntegralDomain ring

|||The type of ring homomorphisms (between rings with identity)
IRHom: (r1: Type) -> Ring_with_identity r1 -> (r2: Type) -> Ring_with_identity r2 -> (f: r1 -> r2) -> Type
IRHom r1 (MkRing_with_identity r1 ((+)) ((*)) pf1) r2 (MkRing_with_identity r2 ((p)) ((m)) pf2) f = (x: r1) -> (y: r1) -> ((f(x+y)) =  (p (f x) (f y)), (f(x*y)) = (m (f x) (f y)), (f e1) = e2) where
  e1 = DPair.fst (Ring_Mult_identity r1 (MkRing_with_identity r1 ((+)) ((*)) pf1))
  e2 = DPair.fst (Ring_Mult_identity r2 (MkRing_with_identity r2 (p) (m) pf2))

|||The type of more flexible ring homomorphisms
RHom:(r1: Type) -> Ring r1 -> (r2: Type) -> Ring r2 -> (f: r1 -> r2) -> Type
RHom r1 (MkRing r1 ((+)) ((*)) pf1) r2 (MkRing r2 ((p)) ((m)) pf2) f = (x: r1) -> (y: r1) -> ((f(x+y)) =  (p (f x) (f y)), (f(x*y)) = (m (f x) (f y)))

|||The type of ideals
IsIdeal: (i: Type) -> Ring i -> (r: Type) -> Ring r -> Type
IsIdeal i pfi r pfr = (DPair (i -> r) (\f => (Inj i r f, RHom i pfi r pfr f, (p: r) -> (t: i) -> (q: i ** ((f q) = (Ring_Mult r pfr p (f t)))) )))

|||The type of principal ideals
IsPrincipalIdeal: (i: Type) -> Ring i -> (r: Type) -> Ring r -> IsIdeal i pfi r pfr -> Type
IsPrincipalIdeal i pfi r pfr (f ** pf) = (p:i ** ((t: i) -> (x: r ** (f t) = (Ring_Mult r pfr x (f p)))) )

|||The type of PID's
IsPID: (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> Type
IsPID ring (+) (*) = (pfURing : IsUsefulRing ring (+) (*) ** ((i: Type) -> (pfi: Ring i) -> (pfIdeal: IsIdeal i pfi ring (CRingisRing ring (URingisCRing ring (MkURing ring (+) (*) pfURing))) ) -> IsPrincipalIdeal i pfi ring (CRingisRing ring (URingisCRing ring (MkURing ring (+) (*) pfURing))) pfIdeal) )

||| Data type for PIDs
data PID: (ring: Type) -> Type where
  MkPID: (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> IsPID ring (+) (*) -> PID ring

||| Euclidean Norm
total
IsEuclideanNorm : (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> (IsIntegralDomain ring (+) (*)) -> (norm : (ring -> Nat)) -> Type
IsEuclideanNorm ring (+) (*) pfIntDomain norm = ( ( (a : ring) -> (b : ring) -> (a = e -> Void) -> (b = e -> Void) -> (LTE (norm a) (norm (a*b))) ) , ( (a : ring) -> (b : ring) -> ((b = e -> Void)) -> (q : ring ** (r : ring ** ( (a = b*q + r) , (LTE (norm r) (norm b) )) )) ) ) where
                                                                                e = fst (RingAdditive_id ring (MkRing ring (+) (*) (fst (snd (fst pfIntDomain))) ) )
||| Euclidean Domain
total
IsEuclideanDomain : (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> Type
IsEuclideanDomain ring (+) (*) = (pfIntDomain : IsIntegralDomain ring (+) (*) ** (EuclNorm : (ring -> Nat) ** (IsEuclideanNorm ring (+) (*) pfIntDomain EuclNorm) ) )

||| Data type for PIDs
data EuclideanDomain: (ring: Type) -> Type where
  MkEuclideanDomain: (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> IsEuclideanDomain ring (+) (*) -> EuclideanDomain ring


module AssRecRule

import Data.Fin
import Data.Vect

{-
 The recursion function for lists of type `a`. Define this by pattern matching
-}
recList : (a: Type) ->  (x: Type) -> x -> (a -> List a -> x -> x) -> (List a -> x)
recList a x y f [] = y
recList a x y f (z :: xs) = f z xs (recList a x y f xs)

{-
Given a list of type `a` and a function `f: a -> b` get a list of type `b`
by applying `f` to each element.
Note: Define using `recList` and without pattern matching on lists.
-}
mapList : (a: Type) -> (b: Type) -> (f: a -> b) -> List a -> List b
mapList a b f xs = recList a (List b) [] g xs where
  g: a -> List a -> List b -> List b
  g x l m = (f x) :: m

{-
Given a list of type `a`, an initial value `init: a` and an operation `op: a -> a -> a`,
get an element of `a` by starting with init and repeatedly applying the elements of the
list,
e.g. fold Nat 1 (*) ([22] :: [3] :: [])  = 1 * 22 * 3
Note: Define using `recList` and without pattern matching on lists.
(op(22,op(3,1))) is the output here
-}
foldList : (a: Type) ->  (init: a) -> (op : a -> a -> a) -> List a -> a
foldList a init op xs = recList a a init g xs where
  g: a -> List a -> a -> a
  g x l y = op x y

{-
The induction function on the `Fin` indexed type family. Define this by pattern matching.
-}
inducFin : (xs : (n: Nat) -> Fin n -> Type) ->
  (base : (m: Nat) -> xs (S m) FZ) ->
  (step : (p: Nat) -> (k: Fin p) ->  (prev: xs p k) -> (xs (S p) (FS k))) ->
  (q: Nat) -> (j: Fin q) -> xs q j
inducFin xs base step (S k) FZ = base k
inducFin xs base step (S k) (FS x) = step k x (inducFin xs base step k x)

{-
Given a type `a`, a natural number `q`, an element `j : Fin q` and a vector `v` of length q with entries of type `a`,
get the element in position `j` of `v`. Note that this is always well defined.

Note: Define using `inducList` and without pattern matching on the `Fin` family. You may pattern match on Vectors.
The definition should have only one case, and there should be no case splitting on `Fin`.
-}
fetchElem : (a: Type) -> (q: Nat) -> (j: Fin q) -> (Vect q a -> a)
fetchElem a q j ys = inducFin xs base step q j ys where
  xs: (n: Nat) -> Fin n -> Type
  xs n j = Vect n a -> a
  base: (m: Nat) -> xs (S m) FZ
  base m = f where
    f: Vect (S m) a -> a
    f (x :: xs) = x
  step: (p: Nat) -> (k: Fin p) ->  (prev: xs p k) -> (xs (S p) (FS k))
  step p k prev = g where
    g: Vect (S p) a -> a
    g (x :: xs) = prev xs


import Data.List.Views
import Data.Vect
import Data.Vect.Views
import Data.Nat.Views

equalSuffix : Eq a => List a -> List a -> List a
equalSuffix input1 input2 with (snocList input1)
  equalSuffix [] input2 | Empty = []
  equalSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
    equalSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = []
    equalSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) =
        if x == y then (equalSuffix xs ys | xsrec | ysrec) ++ [x]
            else []

mergeSort : Ord a => Vect n a -> Vect n a
mergeSort input with (splitRec input)
  mergeSort [] | SplitRecNil = []
  mergeSort [x] | SplitRecOne = [x]
  mergeSort (xs ++ ys) | (SplitRecPair lrec rrec) =
    merge (mergeSort xs | lrec) (mergeSort ys | rrec)

toBinary : Nat -> String
toBinary k with (halfRec k)
  toBinary Z | HalfRecZ = ""
  toBinary (n + n) | (HalfRecEven rec) = toBinary n | rec ++ "0"
  toBinary (S (n + n)) | (HalfRecOdd rec) = toBinary n | rec ++ "1"

palindrome : Eq a => List a -> Bool
palindrome input with (vList input)
  palindrome [] | VNil = True
  palindrome [x] | VOne = True
  palindrome (x :: (xs ++ [y])) | (VCons rec) =
    if x == y then palindrome xs | rec
        else False


module gcd

import ZZ
import Bezout

--isDivisible a b can be constucted if b divides a
isDivisible : Nat -> Nat -> Type
isDivisible a b = (n : Nat ** a = b * n)

--1 divides everything
oneDiv : (a : Nat) -> isDivisible a 1
oneDiv a = (a ** rewrite plusZeroRightNeutral a in Refl)

--If 1|a => 1*c | a*c
mulDiv : (a, c : Nat) -> isDivisible a 1 -> isDivisible (a * c) c
mulDiv a c x = (a ** rewrite multCommutative c a in Refl)

gcdBya : (a : Nat) -> (b : Nat) -> NotBothZero a b -> Nat
gcdBya a b prf = div a (gcd a b {ok=prf})

gcdByb : (a : Nat) -> (b : Nat) -> NotBothZero a b -> Nat
gcdByb a b prf = div b (gcd a b {ok=prf})

|||Genetes a proof of (a+b) = d*(n+m) from (a=d*n)and (b=d*m)
DistributeProof: (a:Nat)->(b:Nat)->(d:Nat)->(n:Nat)->(m:Nat)->(a=d*n)->(b=d*m)->((a+b) = d*(n+m))
DistributeProof a b d n m pf1 pf2 = rewrite  (multDistributesOverPlusRight d n m) in(trans (the (a+b=(d*n)+b) (v1)) v2) where
  v1 =plusConstantRight a (d*n) b pf1
  v2 =plusConstantLeft b (d*m) (d*n) pf2

|||The theorem d|a =>d|ac
MultDiv:(isDivisible a d) ->(c:Nat)->(isDivisible (a*c) d)
MultDiv {d} (n**Refl) c =((n*c)** (rewrite sym (multAssociative d n c) in (Refl)))

|||The theorem d|a and d|b =>d|(a+b)
PlusDiv : (isDivisible a d)->(isDivisible b d)->(isDivisible (a+b) d)
PlusDiv {d}{a}{b} (n**prf1) (m**prf2) = ((n+m)**(DistributeProof a b d n m prf1 prf2))
{-

gcdDiva : (a : Nat) -> (b : Nat) -> NotBothZero a b -> isDivisible a (gcd a b)
gcdDiva a b prf = mulDiv (gcdBya a b prf)
  (gcd a b {ok=prf})
  (oneDiv (gcdBya a b prf))
-}
{-
gcdDivb : (a : Nat) -> (b : Nat) -> NotBothZero a b -> isDivisible b (gcd a b)
gcdDivb a b prf = mulDiv (gcdByb a b prf)
  (gcd a b {ok=prf})
  (oneDiv (gcdByb a b prf))
-}
--gcd is already implemented in the standard library
gcdproof : (a : Nat) -> (b : Nat) -> NotBothZero a b ->
  (d : Nat ** ((k : Nat ** a = d*k),(l : Nat ** b = d*l)))
gcdproof a b prf =
  (gcd a b {ok=prf} ** (?parta, ?partb))

--Proof to finish euclidDivide, couldn't add it as a where clause within euclidDivide. If someone knows how to do that, please do so.
extendedEqualityProof : (a : Nat) -> (b : Nat) -> (q : Nat) -> (r : Nat)-> (S r = b) -> (a = r + (q * b)) -> (S a = (S q) * b)
extendedEqualityProof (r + (q * (S r))) (S r) q r Refl Refl = Refl

--Given a, b, and a proof that b != 0, returns (q, r) and proofs that a = bq + r, r < b  {removed possible problems with Rohit's}
euclidDivide : (a : Nat) -> (b : Nat) -> (b = Z -> Void) -> (q : Nat ** (r : Nat ** ((a = r + (q * b)), LT r b)))
euclidDivide Z (S k) SIsNotZ = (Z ** (Z ** (Refl, LTESucc LTEZero)))
euclidDivide (S n) (S k) SIsNotZ = case (euclidDivide n (S k) SIsNotZ) of
								(q ** (r ** (equalityProof, ltproof))) => case (proofLTimplieseqorLT r (S k) ltproof) of
																	(Right proofSrLTSk) => (q ** ((S r) ** ((functionExtendEquality S n (r + (q * (S k))) equalityProof), proofSrLTSk)))
																	(Left proofSreqSk) => ((S q) ** (Z ** ((extendedEqualityProof n (S k) q r proofSreqSk equalityProof), LTESucc LTEZero)))

--Bezout
{-
--if gcd a b = d, d = ax + by for some x,y Integers (Given by Bezout)
bezproof : (a : Nat) -> (b : Nat) -> NotBothZero a b ->
  (x : (ZZ,ZZ) ** ((cast{from=Nat}{to=ZZ} a)*(fst x) +
                   (cast{from=Nat}{to=ZZ} b)*(snd x) = cast (gcd a b)))
bezproof a b x = (Bezout a b ** ?help)
-}


module Lib2

import Data.List as L

D : Type
D = Double

LD : Type
LD = List D

LLD : Type
LLD = List LD

-- default value of base
b : D
b = 0.03

fullNNLayer : LLD -> LLD -> LLD
fullNNLayer [] _ = []
fullNNLayer _ [] = []
fullNNLayer (x::inps) (y::ws) = (softmax $ nnLayer x y ) :: fullNNLayer inps ws

nnLayer : LD -> LD -> LD
nnLayer xs ys = L.zipWith (\x,y => x * y + b) xs ys

softmax : LD -> LD
softmax xs = let softmax_denom = sum $ map exp $ xs
             in foldr (\x, acc => (exp x)/softmax_denom::acc) [] xs

ceLoss : LD -> LD -> LD
ceLoss  [] _ = []
ceLoss  _ [] = []
ceLoss  (x::xs) (y::ys) = -(y/x) + (1-y)/(1-x)::ceLoss xs ys

adam : LD -> LD -> D ->  D -> D -> D -> D -> D -> LD

adam [] _ _ _ _ _ _ _ = []
adam _ [] _ _ _ _ _ _ = []
adam (t::thetas) (gt::gts) alpha m_prev v_prev beta1 beta2 epsilon = do
  let m_current = (beta1 * m_prev + (1-beta1) * gt) /(1-beta1)
      v_current = (beta2 * v_prev + (1-beta2) * (pow gt 2))/ (1-pow beta2 2)
      mhat_current = m_current / (1-beta1)
      vhat_current = v_current / (1-beta2)
  (t - alpha * mhat_current / ((sqrt vhat_current) + epsilon)) :: adam thetas gts alpha m_current v_current beta1 beta2 epsilon

optimizer : (LD -> LD -> D -> D -> D -> D ->D -> D -> LD) ->
            LLD -> LLD -> D -> D -> D -> D -> D -> D -> LLD

optimizer f [] _ _ _ _ _ _ _ = []
optimizer f _ [] _ _ _ _ _ _ = []
optimizer f (ws::wss) (cs::costs) alpha m v beta1 beta2 epsilon =
  (f ws cs alpha m v beta1 beta2 epsilon) :: optimizer f wss costs alpha m v beta1 beta2 epsilon

record LossFx where
  constructor CreateFx
  fx : LD -> LD -> LD
--  preds, targets : LLD

record Optimizer {a : D} where
  constructor OptimFx
  fx : LD -> LD -> D -> D -> D -> D -> D -> D -> LD
  weights , costs : LLD
  alpha, m, v, beta1, beta2, epsilon : D

record Model where
  constructor Create
  weights, inputs, targets : LLD
  alpha, beta1, beta2, epsilon : D
  iter : Int


module Finmath.Vector

import Finite

--------------------------------------------------------------------------------
-- Equivalence of vectors and maps on finite sets
--------------------------------------------------------------------------------

||| Map from a vector to a function on a finite set
||| Note that this is the Prelude.Vect.index with the arguments reversed.
vectToMap : Vect n a -> Fin n -> a
vectToMap (x :: xs) fZ     = x
vectToMap (x :: xs) (fS k) = vectToMap xs k

||| The inverse of vectToMap
mapToVect : (Fin n -> a) -> Vect n a
mapToVect {n=Z} f     = []
mapToVect {n=(S k)} f = (f fZ) :: (mapToVect (f . fS))

--------------------------------------------------------------------------------
-- Operations on vectors derived from operations on finite sets by duality
--------------------------------------------------------------------------------

||| Concatenates two vectors
concat : Vect n a -> Vect m a -> Vect (n + m) a
concat v w = mapToVect ((either (vectToMap v) (vectToMap w)) . fSetSumInv)

||| Splits a vector
split : Vect (n + m) a -> (Vect n a, Vect m a)
split {n}{m} v = let f = (vectToMap v) . (fSetSum {m=m}{n=n}) in
  (mapToVect (f . Left), mapToVect (f . Right))

||| Unflattens a vector
unFlatten : Vect (n * m) a -> Vect n (Vect m a)
unFlatten v = let f = \x => \y => (vectToMap v) (fSetProduct (x,y)) in
  mapToVect (mapToVect . f)

--------------------------------------------------------------------------------
-- Misc vector operations
--------------------------------------------------------------------------------

||| like Prelude.Vect.findIndices but using Fin, not Nat
findIndices' : (a -> Bool) -> Vect m a -> (p ** Vect p (Fin m))
findIndices' p [] = (_ ** [])
findIndices' p (x::xs) with (findIndices' p xs)
      | (_ ** tail) =
       if p x then
        (_ ** fZ::(map fS tail))
       else
        (_ ** (map fS tail))

-- Heterogeneous (Mixed) Tuples

--Mixed tuple of order k
MixedTuple : (Fin k -> Type) -> Type
MixedTuple sig = (i : Fin _) -> sig i

--Pullback of dependent function
pullback : (a -> b) -> (b -> c) -> (a -> c)
pullback f = \g => g . f

pullback' : (s : a -> Type) -> (s' : b -> Type) -> (f : a -> b) -> s = s' . f -> ((y : b) -> s' y) -> ((x : a) -> s x)
pullback' s s' f p = \g => \x => rewrite p in (g (f x))

--(Unknown name) mapping from mixed tuples induced by mapping on signatures
myMap : (s : Fin k -> Type) -> (s' : Fin k' -> Type) -> (f : Fin k -> Fin k') -> s = s' . f -> MixedTuple s' -> MixedTuple s
myMap s s' f p g = pullback' s s' f p g

NDVector : (Fin k -> Nat) -> Type -> Type
NDVector s a = (MixedTuple (Fin . s)) -> a


module Subst

-- Substitution inside untyped lambda calculus terms.

import Term

%default total
%access public export

shift : (cutoff : Nat) -> (distance : Nat) ->
        Nat -> Nat
shift Z     distance k     = distance+k
shift (S c) distance Z     = Z
shift (S c) distance (S k) = S $ shift c distance k

shiftTerm : (cutoff : Nat) -> (distance : Nat) ->
            Term -> Term
--
shiftTerm c d (TVar i) = TVar (shift c d i)
--
shiftTerm c d (TAbs e) = TAbs $ shiftTerm (S c) d e
--
shiftTerm c d (TApp e1 e2) =
  let e1' = shiftTerm c d e1
      e2' = shiftTerm c d e2
  in TApp e1' e2'
--
shiftTerm c d (TRec e1 e2 e3) =
  let e1' = shiftTerm c d e1
      e2' = shiftTerm c d e2
      e3' = shiftTerm c d e3
  in TRec e1' e2' e3'
--
shiftTerm c d TZero = TZero
--
shiftTerm c d (TSucc e) = TSucc $ shiftTerm c d e
--
shiftTerm c d (TPred e) = TPred $ shiftTerm c d e
--
shiftTerm c d (TIfz e1 e2 e3) =
  let e1' = shiftTerm c d e1
      e2' = shiftTerm c d e2
      e3' = shiftTerm c d e3
  in TIfz e1' e2' e3'

subst_var : Term ->       -- Term that is subtituted in.
            (i : Nat) ->  -- The i-th variable (Var i) is substituted for.
            (j : Nat) ->  -- Substitution takes place inside the term (Var j).
            Term
subst_var ts Z     Z     = ts
subst_var ts Z     (S j) = TVar j
subst_var ts (S i) Z     = TVar Z
subst_var ts (S i) (S j) = shiftTerm Z (S Z) $ subst_var ts i j

subst : Term ->       -- Term that is substituted in.
        (i : Nat) ->  -- The i-th varibale (Var i) is substituted for.
        Term ->       -- Substitution takes place inside this term.
        Term
subst ts i (TVar j)        = subst_var ts i j
subst ts i (TAbs e)        = TAbs $ subst ts (S i) e
subst ts i (TApp e1 e2)    = TApp (subst ts i e1)
                                  (subst ts i e2)
subst ts i (TRec e1 e2 e3) = TRec (subst ts i e1)
                                  (subst ts i e2)
                                  (subst ts i e3)
subst _  _ TZero           = TZero
subst ts i (TSucc e)       = TSucc (subst ts i e)
subst ts i (TPred e)       = TPred (subst ts i e)
subst ts i (TIfz e1 e2 e3) = TIfz (subst ts i e1)
                                  (subst ts i e2)
                                  (subst ts i e3)


module Algebra.Preorder

%default total

||| Preorder defines a binary relation using the `<=` operator
public export
interface Preorder a where
  (<=) : a -> a -> Bool
  preorderRefl : {x : a} -> x <= x = True
  preorderTrans : {x, y, z : a} -> x <= y = True -> y <= z = True -> x <= z = True

||| Least Upper Bound, replace max using only Preorder
export
lub : Preorder a => a -> a -> a
lub x y = if x <= y then y else x

||| Greatest Lower Bound, replaces min using only Preorder
export
glb : Preorder a => a -> a -> a
glb x y = if x <= y then x else y

||| Strict less-than using the relation from a preorder
public export
(<) : (Preorder a, Eq a) => a -> a -> Bool
(<) x y = x <= y && x /= y

||| The greatest bound of a bounded lattice, we only need to know about preorders however
public export
interface Preorder a => Top a where
  top : a
  topAbs : {x : a} -> x <= top = True


import Data.Nat
import Data.Vect

{-
Exercise 1

Using plusZeroRightNeutral and plusSuccRightSucc, write your own version of plusCommutes:

myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n

Hint: Write this by case splitting on n. In the case of S k,
you can rewrite with a recursive call to myPlusCommutes k m, and rewrites can be nested.
 -}
myPlusCommutative : (n : Nat) -> (m : Nat) -> n + m = m + n
myPlusCommutative 0 m = sym (plusZeroRightNeutral m)
{-
Need to prove: S (plus k m) = plus m (S k)

prf1 : plus k m = plus m k
prf2 : S (plus m k) = plus m (S k)

Using prf1,
Rewrite S (plus m k) = plus m (S k)
as      S (plus k m) = plus m (S k)

 -}
myPlusCommutative (S k) m = let prf1 = myPlusCommutative k m
                                prf2 = plusSuccRightSucc m k
                                in
                                rewrite prf1 in prf2

-- Exercise 2

reverseProof_nil : Vect k a -> Vect (plus k 0) a
reverseProof_nil xs = rewrite plusZeroRightNeutral k in xs

reverseProof_xs : Vect (S (plus k len)) a -> Vect (plus k (S len)) a
reverseProof_xs xs = rewrite sym (plusSuccRightSucc k len) in xs

myReverse2 : Vect n a -> Vect n a
myReverse2 xs = reverse' [] xs where
                reverse' : Vect k a -> Vect m a -> Vect (k + m) a
                reverse' acc [] = reverseProof_nil acc
                reverse' acc (x :: xs) = reverseProof_xs (reverse' (x :: acc) xs)


module Proofs.GroupTheory

import Specifications.Group
import Proofs.GroupCancelationLemmas

%default total
%access export

infixl 8 #

groupInverseUnique : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b : s) ->
  a # b = e -> inv a = b
groupInverseUnique {e} spec a b given = o4 @== o3 where
  o1 : inv a # (a # b) = inv a # e
  o1 = cong given
  o2 : inv a # (a # b) = b
  o2 = groupCancel1bis spec a b
  o3 : inv a # e = b
  o3 = o1 @== o2
  o4 : inv a # e = inv a
  o4 = neutralR (monoid spec) _

groupInverseInvolution : GroupSpec _ _ inv -> (a : s) ->
  inv (inv a) = a
groupInverseInvolution spec a =
  groupInverseUnique spec _ a $
  inverseL spec a

groupInverseMutual : GroupSpec _ _ inv -> (a,b : s) ->
  inv a = b -> inv b = a
groupInverseMutual spec a b given =
  cong given @== groupInverseInvolution spec a

groupInverseUniqueBis : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b : s) ->
  a # b = e -> inv b = a
groupInverseUniqueBis spec a b given =
  groupInverseMutual spec a b $
  groupInverseUnique spec a b given

groupInverseNeutral : GroupSpec _ e inv -> inv e = e
groupInverseNeutral {e} spec =
  groupInverseUnique spec e e $
  neutralL (monoid spec) e

groupInverseAnti : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b : s) ->
  inv (a # b) = inv b # inv a
groupInverseAnti spec a b = groupInverseUniqueBis spec _ _ o3 where
  o1 : inv b # inv a # a = inv b
  o1 = groupCancel2bis spec _ a
  o2 : inv b # inv a # a # b = inv b # b
  o2 = cong {f = (# b)} o1
  o3 : inv b # inv a # (a # b) = e
  o3 = associative (monoid spec) _ _ _ === o2 === inverseL spec b

groupInverseAntiInverse : {(#) : Binop s} ->
  GroupSpec (#) e inv -> (a,b : s) ->
    inv (a # inv b) = b # inv a
groupInverseAntiInverse spec a b = o1 === o2 where
  o1 : inv (a # inv b) = inv (inv b) # inv a
  o1 = groupInverseAnti spec a (inv b)
  o2 : inv (inv b) # inv a = b # inv a
  o2 = cong {f = (# inv a)} $ groupInverseInvolution spec b

groupInverseAndEquality : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b : s) ->
  a # inv b = e -> a = b
groupInverseAndEquality {e} spec a b given = o2 @== o1 where
  o1 : a # inv b # b = b
  o1 = cong {f = (# b)} given === neutralL (monoid spec) b
  o2 : a # inv b # b = a
  o2 = groupCancel2bis spec a b


module Matrix

import Data.Vect

addMatrix : Num num => Vect rows (Vect cols num) -> Vect rows (Vect cols num) -> Vect rows (Vect cols num)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = zipWith (+) x y :: addMatrix xs ys

-- We have to bring the implicit {n} into scope before case splitting on it
create_empties : Vect n (Vect 0 elem)
create_empties {n = Z} = []
create_empties {n = (S k)} = [] :: create_empties

transpose_helper : (x : Vect n elem) -> (xs_transpose : Vect n (Vect k elem)) -> Vect n (Vect (S k) elem)
transpose_helper = zipWith (::)
-- transpose_helper [] [] = []
-- transpose_helper (x :: xs) (y :: ys) = (x :: y) :: transpose_helper xs ys

transposeMatrix : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMatrix [] = create_empties
transposeMatrix (x :: xs) = let xs_transpose = transposeMatrix xs in
                                transpose_helper x xs_transpose

total multiplyOneRow : Num num => Vect m num -> Vect p (Vect m num) -> Vect p num
multiplyOneRow xs [] = []
multiplyOneRow xs (x :: ys) = (foldl (+) 0 (zipWith (*) xs x)) :: multiplyOneRow xs ys

total multiplyTransposedMatrices : Num num => Vect n (Vect m num) -> Vect p (Vect m num) -> Vect n (Vect p num)
multiplyTransposedMatrices [] ys = []
multiplyTransposedMatrices (x :: xs) ys = multiplyOneRow x ys :: multiplyTransposedMatrices xs ys

total multMatrix : Num num => Vect n (Vect m num) -> Vect m (Vect p num) -> Vect n (Vect p num)
multMatrix xs ys = multiplyTransposedMatrices xs (transposeMatrix ys)


module Matrix

import Data.Vect
import fn_to_vect

%access public export

ZeroRow : (n : Nat) -> (typ : Type) -> (zero : typ) -> Vect n typ
ZeroRow Z typ zero = []
ZeroRow (S n) typ zero = zero::(ZeroRow n typ zero)

total
ZeroMat : (n : Nat) -> (m : Nat) -> (typ : Type) -> (zero : typ) -> Vect n (Vect m typ)
ZeroMat Z m typ zero = []
ZeroMat (S n) m typ zero = (ZeroRow m typ zero) :: (ZeroMat n m typ zero)

total
innerPdt : (n : Nat) -> (typ : Type) -> ((*) : typ -> typ -> typ) ->
           ((+) : typ -> typ -> typ) -> (zero : typ) ->
           Vect n typ -> Vect n typ -> typ

innerPdt Z typ (*) (+) zero [] [] = zero
innerPdt (S k) typ (*) (+) zero (x::xs) (y::ys) =
    x*y + (innerPdt k typ (*) (+) zero xs ys)

total
mulVect : (m : Nat) -> (k : Nat) -> (typ : Type) ->
          ((*) : typ -> typ -> typ) ->
          ((+) : typ -> typ -> typ) -> (zero : typ) ->
          Vect m typ -> Vect m (Vect k typ) -> Vect k typ

mulVect m k typ (*) (+) zero x ys = map (innerPdt m typ (*) (+) zero x) (transpose ys)

mulMat : (n : Nat) -> (m : Nat) -> (k : Nat) -> (typ : Type) ->
         ((*) : typ -> typ -> typ) -> ((+) : typ -> typ -> typ) -> (zero : typ) ->
         Vect n (Vect m typ) -> Vect m (Vect k typ) -> Vect n (Vect k typ)

mulMat Z m k typ (*) (+) zero [] xs = []
mulMat (S n) m k typ (*) (+) zero (x::xs) ys =
    (mulVect m k typ (*) (+) zero x ys)::(mulMat n m k typ (*) (+) zero xs ys)

Identity_Bool : (n : Nat) -> (Mat_Vect n n Bool)
Identity_Bool n = Diag_Mat_Vect n Bool False True

addMat : (n : Nat) -> (m : Nat) -> (ty : Type) ->
         ((+) : ty -> ty -> ty) -> (Mat_Vect n m ty) ->
         (Mat_Vect n m ty) -> (Mat_Vect n m ty)
addMat n m ty (+) u v = (Mat_fn_to_Vect n m ty fn) where
    fn_u : Mat_fn n m ty
    fn_u = Mat_Vect_to_fn n m ty u

    fn_v : Mat_fn n m ty
    fn_v = Mat_Vect_to_fn n m ty v

    fn : Mat_fn n m ty
    fn i j = (fn_u i j) + (fn_v i j)


module Proofs.GroupCancelationLemmas

import Specifications.Group
import Symmetry.Opposite

%default total
%access export

infixl 8 #

||| cancel two factors in a product of three
groupCancel1 : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b : s) ->
  (inv a # a) # b = b
groupCancel1 spec a b = o2 === o3 where
  o1 : inv a # a = e
  o1 = inverseL spec a
  o2 : (inv a # a) # b = e # b
  o2 = cong {f = (# b)} o1
  o3 : e # b = b
  o3 = neutralL (monoid spec) b

||| cancel two factors in a product of three
groupCancel1bis : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b : s) ->
  inv a # (a # b) = b
groupCancel1bis spec a b = assoc === groupCancel1 spec a b where
  assoc : inv a # (a # b) = (inv a # a) # b
  assoc = associative (monoid spec) _ _ _

||| cancel two factors in a product of three
groupCancel2 : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b : s) ->
  a # (inv b # b) = a
groupCancel2 spec a b = o2 === o3 where
  o1 : inv b # b = e
  o1 = inverseL spec b
  o2 : a # (inv b # b) = a # e
  o2 = cong o1
  o3 : a # e = a
  o3 = neutralR (monoid spec) a

||| cancel two factors in a product of three
groupCancel2bis : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b : s) ->
  (a # inv b) # b = a
groupCancel2bis spec a b = assoc @== groupCancel2 spec a b where
  assoc : a # (inv b # b) = (a # inv b) # b
  assoc = associative (monoid spec) _ _ _

||| cancel two factors in a product of three
groupCancel3 : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b : s) ->
  a # (b # inv b) = a
groupCancel3 spec a b = groupCancel1 (opposite spec) b a

||| cancel two factors in a product of three
groupCancel3bis : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b : s) ->
  (a # b) # inv b = a
groupCancel3bis spec a b = groupCancel1bis (opposite spec) b a

||| cancel two factors in a product of three
groupCancelAbelian : {(#) : Binop s} ->
  GroupSpec (#) e inv -> isAbelian (#) -> (a,b : s) ->
    a # (b # inv a) = b
groupCancelAbelian spec abel a b = abel a _ === o1 where
  o1 : (b # inv a) # a = b
  o1 = groupCancel2bis spec b a

||| Translations are injective.
groupTranslationInjectiveL : {(#) : Binop s} ->
  GroupSpec (#) e inv -> (a,x,y : s) -> a # x = a # y -> x = y
groupTranslationInjectiveL spec a x y given = o2 where
  o1 : inv a # (a # x) = inv a # (a # y)
  o1 = cong given
  o2 : x = y
  o2 = groupCancel1bis spec a x @== o1 === groupCancel1bis spec a y

||| ab = a implies b = e
groupCancelGivesNeutral : {(#) : Binop s} ->
  GroupSpec (#) e inv -> (a,b : s) ->
    a # b = a -> b = e
groupCancelGivesNeutral spec a b given = o2 === inverseL spec a where
  o1 : inv a # (a # b) = inv a # a
  o1 = cong given
  o2 : b = inv a # a
  o2 = groupCancel1bis spec a b @== o1


module IntegerOrdering

-- Note that unlike (=) the types do not inherently need to be ambiguous
class OrdRel A where
	LT : A -> A -> Type

class (OrdRel s) => DecLT s where
	decLT : (x1 : s) -> (x2 : s) -> Dec ( LT x1 x2 )

LTZero : Integer -> Type
LTZero x = Not (x = abs x)

instance OrdRel Integer where
	LT a b = LTZero (a-b)

decLTBigInt : (a : Integer) -> (b : Integer) -> Dec ( LT a b )
decLTBigInt a b = case ( decEq (a-b) (abs (a-b)) ) of
		Yes prPos => No (\false => false prPos)
		No prNeg => Yes prNeg

instance DecLT Integer where
	decLT = decLTBigInt