module biswajitnag.Odds

import Evens

import Intro

-- Define an inductive type family IsOdd : Nat -> Type such that IsOdd n is inhabited if and only if n is odd.

data IsOdd : Nat -> Type where
  OneOdd : IsOdd 1
  SSOdd : (n: Nat) -> IsOdd n -> IsOdd ( S ( S ( n ) ) )

-- Show that 3 is odd.

Q2: IsOdd 3
Q2 = SSOdd 1 OneOdd

-- Show that 2 is not odd.

Q3: IsOdd 2 -> Void
Q3 (SSOdd Z OneOdd) impossible
Q3 (SSOdd Z (SSOdd _ _)) impossible

-- Show that if n: Nat is odd, then its successor S n is even.

Q4: (n: Nat) -> IsOdd n -> IsEven (S n)
Q4 (S Z) OneOdd = SSEven Z ZEven
Q4 (S (S n)) (SSOdd n x) = SSEven (S n) (Q4 n x)

-- Show that if n: Nat is even, then its successor S n is odd.

Q5: (n: Nat) -> IsEven n -> IsOdd (S n)
Q5 Z ZEven = OneOdd
Q5 (S (S n)) (SSEven n x) = SSOdd (S n) (Q5 n x)

-- Show that every number n : Nat is either even or odd.

Q6: (n: Nat) -> Either (IsEven n) (IsOdd n)
Q6 Z = Left ZEven
Q6 (S k) = case (Q6 k) of
                (Left l) => Right (Q5 k l)
                (Right r) => Left (Q4 k r)

-- Show that no number n: Nat is both even and odd.

Q7: (n: Nat) -> IsEven n -> IsOdd n -> Void
Q7 Z ZEven OneOdd impossible
Q7 Z ZEven (SSOdd _ _) impossible
Q7 (S (S k)) (SSEven k x) (SSOdd k y) = Q7 k x y

-- Show that if n: Nat and m: Nat are odd, then add n m is even (here add is from the intro).

Q8: (n: Nat) -> IsOdd n -> (m: Nat) -> IsOdd m -> IsEven (add n m)
Q8 (S Z) OneOdd m y = Q4 m y
Q8 (S (S k)) (SSOdd k x) m y = SSEven (add k m) (Q8 k x m y)

-- Show that if n: Nat is odd, then there exists m: Nat such that n = S (double m).

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

Q9: (n: Nat) -> IsOdd n -> (m: Nat ** n = S (double m))
Q9 (S Z) OneOdd = (Z ** Refl)
Q9 (S (S k)) (SSOdd k x) = case (Q9 k x) of
                                (m ** y) => ((S m) ** (apNat (\n: Nat => (S (S n))) k (S(double m)) y))


module AssRecRule

import Data.Fin
import Data.Vect
%default total
%access public export

{-
 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 base step [] = base
recList a x base step (y :: xs) = (step y xs previous) where
  previous = recList a x base step 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 = recList a (List b) [] step where
  step = \y:a => \xs:(List a)  => \blist:(List b) => (f(y)::blist)

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

|||The way I have defined foldList, if init =p and list is [q,r], it will return
|||op((op(p,r)),q).
foldList : (a: Type) ->  (init: a) -> (op : a -> a -> a) -> List a -> a
foldList a init op = recList a a init step where
  step = \y:a => \xs:(List a) => \previous:a => (op previous 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`.
-}

|||Specifies the output type for fetchelem
outTypeFetchElem: (a:Type) ->(n:Nat) -> Fin n -> Type
outTypeFetchElem a n x = (Vect n a ->a)

baseFetchElem : (m : Nat) -> Vect (S m) a -> a
baseFetchElem m (x :: xs) = x

stepFetchElem : (p : Nat) -> Fin p -> (Vect p a -> a) -> Vect (S p) a -> a
stepFetchElem p x f (y :: xs) = f (xs)

fetchElem : (a: Type) -> (q: Nat) -> (j: Fin q) -> (Vect q a -> a)
fetchElem a   = inducFin (outTypeFetchElem a) baseFetchElem stepFetchElem


module AssRecRule

import Data.Fin
import Data.Vect

%default total

{-
 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 x0 f [] = x0
recList a x x0 f (head::lista) = f head lista (recList a x x0 f lista)
{-
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 lista = recList a (List b) [] (\a => (\lista => (\listb => (f a)::listb))) lista

{-
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.
-}
foldList : (a: Type) ->  (init: a) -> (op : a -> a -> a) -> List a -> a
foldList a a0 op lista = recList a a a0 (\a => (\lista => (\val => op a val))) lista

{-
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 n) FZ = base n
inducFin xs base step (S n) (FS k) = step n k (inducFin xs base step n k)

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

fetchElem : (a: Type) -> (q: Nat) -> (j: Fin q) -> (Vect q a -> a)
fetchElem a q j v = (inducFin xs base step q j) v where
	xs : (n: Nat) -> Fin n -> Type
	xs n k = (Vect n a -> a)
	base : (m: Nat) -> xs (S m) FZ
	base m (x :: v) = x
	step :  (p: Nat) -> (k: Fin p) ->  (prev: xs p k) -> (xs (S p) (FS k))
	step p k prev (x :: v) = prev v


module Data.ZZ

import Decidable.Equality
import Sign

%default total
%access public export

||| An integer is either a positive `Nat` or the negated successor of a `Nat`.
|||
||| For example, 3 is `Pos 3` and -2 is `NegS 1`. Zero is arbitrarily chosen
||| to be positive.
|||
data ZZ = Pos Nat | NegS Nat

implementation Signed ZZ where
  sign (Pos Z) = Zero
  sign (Pos _) = Plus
  sign (NegS _) = Minus

||| Take the absolute value of a `ZZ`
absZ : ZZ -> Nat
absZ (Pos n) = n
absZ (NegS n) = S n

implementation Show ZZ where
  showPrec d (Pos n) = showPrec d n
  showPrec d (NegS n) = showParens (d >= PrefixMinus) $ "-" ++ showPrec PrefixMinus (S n)

negNat : Nat -> ZZ
negNat Z = Pos Z
negNat (S n) = NegS n

||| Construct a `ZZ` as the difference of two `Nat`s
minusNatZ : Nat -> Nat -> ZZ
minusNatZ n Z = Pos n
minusNatZ Z (S m) = NegS m
minusNatZ (S n) (S m) = minusNatZ n m

||| Add two `ZZ`s. Consider using `(+) {a=ZZ}`.
plusZ : ZZ -> ZZ -> ZZ
plusZ (Pos n) (Pos m) = Pos (n + m)
plusZ (NegS n) (NegS m) = NegS (S (n + m))
plusZ (Pos n) (NegS m) = minusNatZ n (S m)
plusZ (NegS n) (Pos m) = minusNatZ m (S n)

implementation Eq ZZ where
  (Pos n) == (Pos m) = n == m
  (NegS n) == (NegS m) = n == m
  _ == _ = False

implementation Ord ZZ where
  compare (Pos n) (Pos m) = compare n m
  compare (NegS n) (NegS m) = compare m n
  compare (Pos _) (NegS _) = GT
  compare (NegS _) (Pos _) = LT

||| Multiply two `ZZ`s. Consider using `(*) {a=ZZ}`.
multZ : ZZ -> ZZ -> ZZ
multZ (Pos n) (Pos m) = Pos $ n * m
multZ (NegS n) (NegS m) = Pos $ (S n) * (S m)
multZ (NegS n) (Pos m) = negNat $ (S n) * m
multZ (Pos n) (NegS m) = negNat $ n * (S m)

||| Convert an `Integer` to an inductive representation.
fromInt : Integer -> ZZ
fromInt n = if n < 0
            then NegS $ fromInteger ((-n) - 1)
            else Pos $ fromInteger n

implementation Cast Nat ZZ where
  cast n = Pos n

implementation Num ZZ where
  (+) = plusZ
  (*) = multZ
  fromInteger = fromInt

implementation Abs ZZ where
    abs = cast . absZ

mutual
  implementation Neg ZZ where
    negate (Pos Z)     = Pos Z
    negate (Pos (S n)) = NegS n
    negate (NegS n)    = Pos (S n)

    (-) = subZ

  ||| Subtract two `ZZ`s. Consider using `(-) {a=ZZ}`.
  subZ : ZZ -> ZZ -> ZZ
  subZ n m = plusZ n (negate m)

implementation Cast ZZ Integer where
  cast (Pos n) = cast n
  cast (NegS n) = (-1) * (cast n + 1)

implementation Cast Integer ZZ where
  cast = fromInteger

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

natPlusZPlus : (n : Nat) -> (m : Nat) -> (x : Nat)
             -> n + m = x -> (Pos n) + (Pos m) = Pos x
natPlusZPlus n m x h = cong h

natMultZMult : (n : Nat) -> (m : Nat) -> (x : Nat)
             -> n * m = x -> (Pos n) * (Pos m) = Pos x
natMultZMult n m x h = cong h

doubleNegElim : (z : ZZ) -> negate (negate z) = z
doubleNegElim (Pos Z) = Refl
doubleNegElim (Pos (S n)) = Refl
doubleNegElim (NegS Z) = Refl
doubleNegElim (NegS (S n)) = Refl

-- Injectivity
posInjective : Pos n = Pos m -> n = m
posInjective Refl = Refl

negSInjective : NegS n = NegS m -> n = m
negSInjective Refl = Refl

posNotNeg : Pos n = NegS m -> Void
posNotNeg Refl impossible

-- Decidable equality
implementation DecEq ZZ where
  decEq (Pos n) (NegS m) = No posNotNeg
  decEq (NegS n) (Pos m) = No $ negEqSym posNotNeg
  decEq (Pos n) (Pos m) with (decEq n m)
    | Yes p = Yes $ cong p
    | No p = No $ \h => p $ posInjective h
  decEq (NegS n) (NegS m) with (decEq n m)
    | Yes p = Yes $ cong p
    | No p = No $ \h => p $ negSInjective h

-- Plus

plusZeroLeftNeutralZ : (right : ZZ) -> 0 + right = right
plusZeroLeftNeutralZ (Pos n) = Refl
plusZeroLeftNeutralZ (NegS n) = Refl

plusZeroRightNeutralZ : (left : ZZ) -> left + 0 = left
plusZeroRightNeutralZ (Pos n) = cong $ plusZeroRightNeutral n
plusZeroRightNeutralZ (NegS n) = Refl

plusCommutativeZ : (left : ZZ) -> (right : ZZ) -> (left + right = right + left)
plusCommutativeZ (Pos n) (Pos m) = cong $ plusCommutative n m
plusCommutativeZ (Pos n) (NegS m) = Refl
plusCommutativeZ (NegS n) (Pos m) = Refl
plusCommutativeZ (NegS n) (NegS m) = cong {f=NegS} $ cong {f=S} $ plusCommutative n m

minusNatZAntiCommutative : (j, k : Nat) -> negate (minusNatZ j k) = minusNatZ k j
minusNatZAntiCommutative Z Z = Refl
minusNatZAntiCommutative Z (S k) = Refl
minusNatZAntiCommutative (S j) Z = Refl
minusNatZAntiCommutative (S j) (S k) = minusNatZAntiCommutative j k

negateDistributesPlus : (a, b : ZZ) -> negate (a + b) = (negate a) + (negate b)
negateDistributesPlus (Pos Z) b = rewrite plusZeroLeftNeutralZ b in
                                  rewrite plusZeroLeftNeutralZ (negate b) in Refl
negateDistributesPlus (Pos (S k)) (Pos Z) = rewrite plusZeroRightNeutral k in Refl
negateDistributesPlus (Pos (S k)) (Pos (S j)) = rewrite plusCommutative k (S j) in
                                                rewrite plusCommutative j k in Refl
negateDistributesPlus (Pos (S k)) (NegS j) = minusNatZAntiCommutative k j
negateDistributesPlus (NegS k) (Pos Z) = rewrite plusZeroRightNeutral k in Refl
negateDistributesPlus (NegS k) (Pos (S j)) = minusNatZAntiCommutative j k
negateDistributesPlus (NegS k) (NegS j) = rewrite plusCommutative k (S j) in
                                          rewrite plusCommutative k j in Refl

lemmaMinusSucc : (k, j, i : Nat) -> plusZ (minusNatZ k (S j)) (Pos i) = plusZ (minusNatZ k (S (S j))) (Pos (S i))
lemmaMinusSucc Z j i = Refl
lemmaMinusSucc (S Z) Z i = Refl
lemmaMinusSucc (S (S k)) Z i = rewrite plusCommutative k (S i) in
                               rewrite plusCommutative i k in Refl
lemmaMinusSucc (S k) (S j) i = lemmaMinusSucc k j i

lemmaAssocNegation : (k : Nat) -> (c, r : ZZ) -> (Pos (S k)) + (c + r) = ((Pos (S k)) + c) + r -> (NegS k) + ((negate c) + (negate r)) = ((NegS k) + (negate c)) + (negate r)
lemmaAssocNegation k c r prf = rewrite sym $ negateDistributesPlus c r in
                               rewrite sym $ negateDistributesPlus (Pos (S k)) (plusZ c r) in
                               rewrite sym $ negateDistributesPlus (Pos (S k)) c in
                               rewrite sym $ negateDistributesPlus (plusZ (Pos (S k)) c) r in
                               cong $ prf

lemmaAssocPos : (k : Nat) -> (c, r : ZZ) -> (Pos k) + (c + r) = ((Pos k) + c) + r
lemmaAssocPos k (Pos j) (Pos i) = cong $ plusAssociative k j i
lemmaAssocPos k (Pos Z) (NegS i) = rewrite plusZeroRightNeutral k in Refl
lemmaAssocPos k (Pos (S j)) (NegS Z) = rewrite plusCommutative k (S j) in
                                       rewrite plusCommutative j k in Refl
lemmaAssocPos k (Pos (S j)) (NegS (S i)) = let ind = lemmaAssocPos k (assert_smaller (Pos (S j)) (Pos j)) (assert_smaller (NegS (S i)) (NegS i)) in
                                           rewrite ind in
                                           rewrite plusCommutative k (S j) in
                                           rewrite plusCommutative j k in Refl
lemmaAssocPos k (NegS j) (Pos Z) = rewrite plusZeroRightNeutralZ (minusNatZ k (S j)) in Refl
lemmaAssocPos Z (NegS Z) (Pos (S i)) = Refl
lemmaAssocPos (S k) (NegS Z) (Pos (S i)) = rewrite plusCommutative k (S i) in
                                           rewrite plusCommutative k i in Refl
lemmaAssocPos k (NegS (S j)) (Pos (S i)) = let ind = lemmaAssocPos k (assert_smaller (NegS (S j)) (NegS j)) (assert_smaller (Pos (S i)) (Pos i)) in
                                           rewrite ind in
                                           rewrite lemmaMinusSucc k j i in Refl
lemmaAssocPos Z (NegS j) (NegS i) = Refl
lemmaAssocPos (S k) (NegS Z) (NegS i) = Refl
lemmaAssocPos (S k) (NegS (S j)) (NegS i) = let ind = lemmaAssocPos (assert_smaller (S k) k) (assert_smaller (NegS (S j)) (NegS j)) (NegS i) in
                                            rewrite ind in Refl

plusAssociativeZ : (l, c, r : ZZ) -> l + (c + r) = (l + c) + r
plusAssociativeZ (Pos k) c r = lemmaAssocPos k c r
plusAssociativeZ (NegS k) c r = rewrite sym $ doubleNegElim c in
                                rewrite sym $ doubleNegElim r in
                                lemmaAssocNegation k (negate c) (negate r) (lemmaAssocPos (S k) (negate c) (negate r))

lemmaMinusSymmZero : (k : Nat) -> minusNatZ k k = Pos 0
lemmaMinusSymmZero Z = Refl
lemmaMinusSymmZero (S k) = let ind = lemmaMinusSymmZero k in
                           rewrite ind in Refl

plusNegateInverseLZ : (a : ZZ) -> a + negate a = Pos Z
plusNegateInverseLZ (Pos Z) = Refl
plusNegateInverseLZ (Pos (S k)) = rewrite lemmaMinusSymmZero k in Refl
plusNegateInverseLZ (NegS k) = rewrite lemmaMinusSymmZero k in Refl

plusNegateInverseRZ : (a : ZZ) -> negate a + a = Pos Z
plusNegateInverseRZ (Pos Z) = Refl
plusNegateInverseRZ (Pos (S k)) = rewrite lemmaMinusSymmZero k in Refl
plusNegateInverseRZ (NegS k) = rewrite lemmaMinusSymmZero k in Refl

-- Mult
multZeroLeftZeroZ : (right : ZZ) -> (Pos Z) * right = (Pos Z)
multZeroLeftZeroZ (Pos k) = Refl
multZeroLeftZeroZ (NegS k) = Refl

multZeroRightZeroZ : (left : ZZ) -> left * (Pos Z) = (Pos Z)
multZeroRightZeroZ (Pos k) = rewrite multZeroRightZero k in Refl
multZeroRightZeroZ (NegS k) = rewrite multZeroRightZero k in Refl

multOneLeftNeutralZ : (right : ZZ) -> 1 * right = right
multOneLeftNeutralZ (Pos k) = rewrite plusZeroRightNeutral k in Refl
multOneLeftNeutralZ (NegS k) = rewrite plusZeroRightNeutral k in Refl

multOneRightNeutralZ : (left : ZZ) -> left * 1 = left
multOneRightNeutralZ (Pos Z) = Refl
multOneRightNeutralZ (Pos (S k)) = cong $ multOneRightNeutral (S k)
multOneRightNeutralZ (NegS k) = cong $ multOneRightNeutral k

multCommutativeZ : (left : ZZ) -> (right : ZZ) -> (left * right = right * left)
multCommutativeZ (Pos k) (Pos j) = cong $ multCommutative k j
multCommutativeZ (Pos k) (NegS j) = rewrite multCommutative j k in
                                    cong $ multRightSuccPlus k j
multCommutativeZ (NegS k) (Pos j) = rewrite multCommutative j (S k) in Refl
multCommutativeZ (NegS k) (NegS j) = cong $ multCommutative (S k) (S j)

lemmaPosMultNegNat : (k, j : Nat) -> multZ (Pos k) (negNat j) = negNat (mult k j)
lemmaPosMultNegNat k Z = rewrite multZeroRightZero k in Refl
lemmaPosMultNegNat k (S j) = Refl

lemmaNegMultNegNat : (k, j : Nat) -> multZ (NegS k) (negNat j) = multZ (Pos (S k)) (Pos j)
lemmaNegMultNegNat k Z = rewrite multZeroRightZero k in Refl
lemmaNegMultNegNat k (S j) = Refl

lemmaNegatePosNegNat : (k : Nat) -> negate (Pos k) = negNat k
lemmaNegatePosNegNat Z = Refl
lemmaNegatePosNegNat (S k) = Refl

multNegLeftZ : (k : Nat) -> (j : ZZ) -> (NegS k) * j = negate (Pos (S k) * j)
multNegLeftZ k (Pos j) = rewrite lemmaNegatePosNegNat ((S k) * j) in Refl
multNegLeftZ k (NegS j) = Refl

multNegateLeftZ : (k, j : ZZ) -> (negate k) * j = negate (k * j)
multNegateLeftZ (Pos Z) j = rewrite multZeroLeftZeroZ j in Refl
multNegateLeftZ (Pos (S k)) (Pos j) = rewrite lemmaNegatePosNegNat ((S k) * j) in Refl
multNegateLeftZ (Pos (S k)) (NegS j) = Refl
multNegateLeftZ (NegS k) j = rewrite sym $ doubleNegElim (multZ (Pos (S k)) j) in
                             rewrite multNegLeftZ k j in Refl

multAssociativeZPos : (k : Nat) -> (c, r : ZZ) -> (Pos k) * (c * r) = ((Pos k) * c) * r
multAssociativeZPos k (Pos j) (Pos i) = cong $ multAssociative k j i
multAssociativeZPos k (Pos j) (NegS i) = rewrite sym $ multAssociative k j (S i) in lemmaPosMultNegNat k (mult j (S i))
multAssociativeZPos k (NegS j) (Pos i) = rewrite multCommutative j i in
                                         rewrite sym $ multRightSuccPlus i j in
                                         rewrite lemmaPosMultNegNat k (mult i (S j)) in
                                         rewrite multCommutativeZ (negNat (mult k (S j))) (Pos i) in
                                         rewrite lemmaPosMultNegNat i (mult k (S j)) in
                                         rewrite multAssociative k i (S j) in
                                         rewrite multAssociative i k (S j) in
                                         rewrite multCommutative i k in Refl
multAssociativeZPos k (NegS j) (NegS i) = rewrite multCommutativeZ (negNat (mult k (S j))) (NegS i) in
                                          rewrite lemmaNegMultNegNat i (mult k (S j)) in
                                          rewrite multAssociative k (S j) (S i) in
                                          rewrite multCommutative (mult k (S j)) (S i) in Refl

multAssociativeZ : (l, c, r : ZZ) -> l * (c * r) = (l * c) * r
multAssociativeZ (Pos k) c r = multAssociativeZPos k c r
multAssociativeZ (NegS k) c r = rewrite multNegLeftZ k (c * r) in
                                rewrite multNegLeftZ k c in
                                rewrite multNegateLeftZ (multZ (Pos (S k)) c) r in
                                cong $ multAssociativeZPos (S k) c r

lemmaPlusPosNegCancel : (k, j, i : Nat) -> plusZ (Pos (plus k j)) (negNat (plus k i)) = plusZ (Pos j) (negNat i)
lemmaPlusPosNegCancel Z j i = Refl
lemmaPlusPosNegCancel (S Z) j Z = rewrite plusZeroRightNeutral j in Refl
lemmaPlusPosNegCancel (S Z) j (S i) = Refl
lemmaPlusPosNegCancel (S (S k)) j i = lemmaPlusPosNegCancel (S k) j i

lemmaPlusPosNegZero : (k : Nat) -> plusZ (Pos k) (negNat k) = Pos Z
lemmaPlusPosNegZero Z = Refl
lemmaPlusPosNegZero (S k) = rewrite lemmaMinusSymmZero k in Refl

negNatDistributesPlus : (j, k : Nat) -> plusZ (negNat j) (negNat k) = negNat (plus j k)
negNatDistributesPlus Z k = rewrite plusZeroLeftNeutralZ (negNat k) in Refl
negNatDistributesPlus (S j) Z = rewrite plusZeroRightNeutral j in Refl
negNatDistributesPlus (S j) (S k) = rewrite plusSuccRightSucc j k in Refl

-- Distributivity

multDistributesOverPlusRightPosPosZ : (l, c : Nat) -> (r : ZZ) -> (Pos l) * ((Pos c) + r) = ((Pos l) * (Pos c)) + ((Pos l) * r)
multDistributesOverPlusRightPosPosZ l c (Pos i) = rewrite multDistributesOverPlusRight l c i in Refl
multDistributesOverPlusRightPosPosZ l Z (NegS i) = rewrite multZeroRightZero l in
                                                   rewrite plusZeroLeftNeutralZ (negNat (mult l (S i))) in Refl
multDistributesOverPlusRightPosPosZ l (S c) (NegS Z) = rewrite multOneRightNeutral l in
                                                       rewrite multRightSuccPlus l c in
                                                       rewrite sym $ plusAssociativeZ (Pos l) (Pos (mult l c)) (negNat l) in
                                                       rewrite plusCommutativeZ (Pos (mult l c)) (negNat l) in
                                                       rewrite plusAssociativeZ (Pos l) (negNat l) (Pos (mult l c)) in
                                                       rewrite lemmaPlusPosNegZero l in Refl
multDistributesOverPlusRightPosPosZ l (S c) (NegS (S i)) = let ind = multDistributesOverPlusRightPosPosZ l (assert_smaller (S c) c) (assert_smaller (NegS (S i)) (NegS i)) in
                                                           rewrite ind in
                                                           rewrite multRightSuccPlus l (S i) in
                                                           rewrite multRightSuccPlus l c in
                                                           rewrite lemmaPlusPosNegCancel l (mult l c) (mult l (S i)) in Refl

multDistributesOverPlusRightPosZ : (k : Nat) -> (c, r : ZZ) -> (Pos k) * (c + r) = ((Pos k) * c) + ((Pos k) * r)
multDistributesOverPlusRightPosZ k (Pos j) r = multDistributesOverPlusRightPosPosZ k j r
multDistributesOverPlusRightPosZ k (NegS j) (Pos i) = rewrite plusCommutativeZ ((Pos k) * (NegS j)) ((Pos k) * (Pos i)) in
                                                      rewrite multDistributesOverPlusRightPosPosZ k i (NegS j) in Refl
multDistributesOverPlusRightPosZ k (NegS j) (NegS i) = rewrite negNatDistributesPlus (mult k (S j)) (mult k (S i)) in
                                                       rewrite sym $ multDistributesOverPlusRight k (S j) (S i) in
                                                       rewrite plusSuccRightSucc j i in Refl

multDistributesOverPlusRightZ : (l, c, r : ZZ) -> l * (c + r) = (l * c) + (l * r)
multDistributesOverPlusRightZ (Pos k) c r = multDistributesOverPlusRightPosZ k c r
multDistributesOverPlusRightZ (NegS k) c r = rewrite multNegLeftZ k (plusZ c r) in
                                             rewrite multNegLeftZ k c in
                                             rewrite multNegLeftZ k r in
                                             rewrite sym $ negateDistributesPlus (multZ (Pos (S k)) c) (multZ (Pos (S k)) r) in
                                             rewrite multDistributesOverPlusRightPosZ (S k) c r in Refl

multDistributesOverPlusLeftZ : (l, c, r : ZZ) -> (l + c) * r = (l * r) + (c * r)
multDistributesOverPlusLeftZ l c r = rewrite multCommutativeZ (l + c) r in
                                     rewrite multDistributesOverPlusRightZ r l c in
                                     rewrite multCommutativeZ r l in
                                     rewrite multCommutativeZ r c in Refl
plusConstantRightZ : (left : ZZ) ->
                    (right : ZZ) ->
                    (c : ZZ) -> (left = right) -> left+c = right+c
plusConstantRightZ right right c Refl = Refl

plusConstantLeftZ :(left : ZZ) ->
    (right : ZZ) -> (c : ZZ) -> (p : left = right) -> c + left = c + right
plusConstantLeftZ right right c Refl = Refl

|||A type that is occupied only when the integer is positive
data IsPositive :ZZ->Type where
  Positive : (IsPositive (Pos(S k)))
data IsNotPositive :ZZ->Type where
  Zero:(IsNotPositive (Pos 0))
  Negative :(IsNotPositive (NegS k))
|||Proof that 0 is not positive
ZeroNOtPositive : IsPositive (Pos 0) -> Void
ZeroNOtPositive Positive impossible
|||Proof that negative numbers are not positive
NegNotPositive : IsPositive (NegS k) -> Void
NegNotPositive Positive impossible
|||A function that returns either a proof that a function is positive or a contradiction
DecidePositive:(a:ZZ)->Dec (IsPositive a)
DecidePositive (Pos Z) = No ZeroNOtPositive
DecidePositive (Pos (S k)) = Yes Positive
DecidePositive (NegS k) = No (NegNotPositive)

|||A proof that a=b => (-a)=(-b)
numbersSameNegativesSame: {a:ZZ}->{b:ZZ}->((a)=(b))->((-a)=(-b))
numbersSameNegativesSame Refl = Refl
|||A proof that  (-a)=(-b) => a=b
negativesSameNumbersSame :{a:ZZ}->{b:ZZ}->((-a)=(-b))->((a)=(b))
negativesSameNumbersSame {a} {b} prf = rewrite sym (doubleNegElim a) in (rewrite sym (doubleNegElim b) in (numbersSameNegativesSame prf))
|||The theorem k*(-j) = -(k*j)
multNegateRightZ:(k, j : ZZ) -> k * (negate j) = negate (k * j)
multNegateRightZ k j = (rewrite (multCommutativeZ k (-j)) in(rewrite ((multCommutativeZ k j)) in (multNegateLeftZ j k)))

|||The theorem (a=(b*c)) => ((-a)=(b*(-c)))
multNegateRightIsNegateZ:(a:ZZ)->(b:ZZ)->(c:ZZ)->(a=(b*c))->((-a)=(b*(-c)))
multNegateRightIsNegateZ a b c prf = (rewrite (multNegateRightZ b c) in ( numbersSameNegativesSame prf))
|||The theorem that ((a+b)+(-b))=a
addAndSubNeutralZ: (a:ZZ)->(b:ZZ)->(((a+b)+(-b))=a)
addAndSubNeutralZ a b = rewrite (sym (plusAssociativeZ a b (-b))) in (rewrite (plusNegateInverseLZ b) in (rewrite (plusZeroRightNeutralZ a) in Refl))

--------------------------------------------------------------------------------------------------------------------------------------------------------------------
--Some more functions of Natural numbers that might be useful
---------------------------------------------------------------------------------------------------------------------------------------------------------------------
|||The theorem that (m<=n) and (n<=m) implies n=m
lteAndGteImpliesEqual:{m:Nat}-> {n:Nat}->(LTE m n)-> (LTE n m)->(n=m)
lteAndGteImpliesEqual LTEZero LTEZero = Refl
lteAndGteImpliesEqual (LTESucc x) (LTESucc y) = cong (lteAndGteImpliesEqual x y)
|||The theorem (m<=n) implies (m<=(c+n))
plusConstantLeftSide:{m:Nat}->{n:Nat}->(c:Nat)->LTE m n ->LTE m (c+n)
plusConstantLeftSide Z x = x
plusConstantLeftSide (S k) x = lteSuccRight (plusConstantLeftSide k x)

plusConstantLeftPreservesLte:{m:Nat}-> {n:Nat}->(c:Nat)->(LTE m n)->(LTE (c+m) (c+n))
plusConstantLeftPreservesLte Z x = x
plusConstantLeftPreservesLte (S k) x = LTESucc (plusConstantLeftPreservesLte k x)

plusConstantRightPreservesLte:{m:Nat}-> {n:Nat}->(c:Nat)->(LTE m n)->(LTE (m+c) (n+c))
plusConstantRightPreservesLte {m}{n}c x = rewrite (plusCommutative m c)  in (rewrite (plusCommutative n c) in (plusConstantLeftPreservesLte c x))

|||The theorem that for any natural numbers k and m (m<= (S k)*m)
natLteMultNatNat: (k:Nat)->(m:Nat)->(LTE m ((S k)*m))
natLteMultNatNat Z m = rewrite (multOneLeftNeutral m) in (lteRefl)
natLteMultNatNat (S k) m =     plusConstantLeftSide m (natLteMultNatNat  k m)

-----------------------------------------------------------------------------------------------------------------
--Implementation of LTE for ZZ
----------------------------------------------------------------------------------------------------------------
|||The less than or equal to type for ZZ
data LTEZ :ZZ->ZZ->Type where
  PositiveLTE: (LTE m n)->LTEZ (Pos m) (Pos n)
  NegLessPositive:LTEZ (NegS m) (Pos n)
  NegativeLte:(LTE m n)->LTEZ (NegS n) (NegS m)

|||The theorem that for positive integers n and m (n<=(m*n))
posLteMultPosPosZ:  (n:ZZ)->(m:ZZ)->(IsPositive n)->(IsPositive m)->(LTEZ n  (m*n))
posLteMultPosPosZ (Pos (S j)) (Pos (S k)) Positive Positive = PositiveLTE (natLteMultNatNat k (S j))

|||The proof that if an integer is not not positive , it is positive (This  looks useless , but I couldnt find a better way to implement some other theorems)
notNotPositiveimpliesPositive:{k:ZZ}->((IsNotPositive k)->Void)->(IsPositive k)
notNotPositiveimpliesPositive {k = (Pos Z)} f = void (f Zero)
notNotPositiveimpliesPositive {k = (Pos (S k))} f = Positive
notNotPositiveimpliesPositive {k = (NegS k)} f = void (f Negative)

|||Proof that Multiplying two Positive numbers doesnt give Zero
zeroIsNotPosMultPos: ((Pos Z) = (Pos (S k))*(Pos(S j)))->Void
zeroIsNotPosMultPos Refl impossible
|||Proof that a positive number is not 0 times a positive number
posIsNotZeroMultPos:((Pos (S j)) = (Pos (Z))*(Pos (S k) ))->Void
posIsNotZeroMultPos Refl impossible
|||Proof that a positive number is not a positive number times 0
posIsNotPosMultZero:((Pos (S j)) = (Pos (S k))*(Pos (Z) ))->Void
posIsNotPosMultZero {j} {k}prf =  posIsNotZeroMultPos {k} (rewrite (multCommutativeZ (Pos Z) (Pos (S k))) in prf)
|||Proof that a positive number times a negative number is not Positive
posIsNotPosMultNeg :((Pos (S j)) = (Pos (S k))*(NegS p ))->Void
posIsNotPosMultNeg Refl impossible

|||Just a helper function for posDivByPosIsPos
PosEqualsPosNegIsContra:(c:ZZ)->(d:ZZ)->(q:ZZ)->(IsPositive c)->(IsPositive d)->(c=(d*q))->((IsNotPositive q)->Void)
PosEqualsPosNegIsContra (Pos (S k)) (Pos (S j)) (Pos Z) Positive Positive prf Zero =posIsNotPosMultZero prf
PosEqualsPosNegIsContra (Pos (S i)) (Pos (S j)) (NegS k) Positive Positive prf Negative = posIsNotPosMultNeg prf

|||Proof that if (c = d*q) and c and d are positive , then q is positive
posDivByPosIsPos:{c:ZZ}->{d:ZZ}->{q:ZZ}->(IsPositive c)->(IsPositive d)->(c=(d*q))->(IsPositive q)
posDivByPosIsPos {c}{d}{q} cPos dPos eqProof = notNotPositiveimpliesPositive (PosEqualsPosNegIsContra c d q cPos dPos eqProof)

|||The theorem (m<=n) and (n<=m) implies n=m for integers
lteAndGteImpliesEqualZ:{m:ZZ}-> {n:ZZ}->(LTEZ m n)-> (LTEZ n m)->(n=m)
lteAndGteImpliesEqualZ (PositiveLTE x) (PositiveLTE y) =  cong (lteAndGteImpliesEqual x y)
lteAndGteImpliesEqualZ NegLessPositive (PositiveLTE _) impossible
lteAndGteImpliesEqualZ NegLessPositive NegLessPositive impossible
lteAndGteImpliesEqualZ NegLessPositive (NegativeLte _) impossible
lteAndGteImpliesEqualZ (NegativeLte x) (NegativeLte y) = cong (lteAndGteImpliesEqual y x)

|||A proof that if c and d are positive and d =c*q then (c<=d)
posLteMultPosPosEqZ: {q:ZZ}->(c:ZZ)->(d:ZZ)->(IsPositive c)->(IsPositive d)->(d=c*q)->(LTEZ c d)
posLteMultPosPosEqZ {q} c d cPos dPos prf = rewrite prf in (rewrite (multCommutativeZ c q) in (posLteMultPosPosZ c q cPos qPos)) where
  qPos= posDivByPosIsPos dPos cPos prf


module Prove

-- One can prove theorems with idris (of course!)

-- propositional equality is defined as below:
--
-- data (=) : a -> b -> Type where
--   Refl : x = x

twoPlusTwo : 2 + 2 = 4
twoPlusTwo = Refl

-- The bottom type (Empty type) has no constructor, we can use it to represent
-- negation of proposition.

disjoint : {n : Nat} -> (Z = S n) -> Void
disjoint p = replace {P = disjointTy} p ()
  where disjointTy : Nat -> Type
        disjointTy Z     = ()
        disjointTy (S _) = Void

-- where the library function `replace' has type of
--
--    replace : (x = y) -> P x -> P y

-- above definition is reduced as:
--
-- replace { P = disjointTy } p ()
-- replace { P = disjointTy } (Z = S n) ()
-- (f : (disjointTy Z -> disjointTy (S n))) ()
-- (f : () -> Void) ()
-- Void

-- now we try prove some simple theorems

plusReduces : {n:Nat} -> (Z + n = n)
plusReduces = Refl
-- since 0 + n is n by the definition of (+).

plusReduces' : (n:Nat) -> (n + Z = n)
plusReduces' Z = Refl
plusReduces' (S k) = cong (plusReduces' k)
-- where `cong' is a library function with type (a = b) -> (f a = f b),
-- representing equality respects function application.

-- To finish the hole we had previously for function `parity', we need to prove
-- that (S (S (j + j))) = (S j) + (S j).

parityHelper1 : (j : Nat) -> (S j + S j) = S (S (j + j))
parityHelper1 Z = Refl
parityHelper1 (S j) = rewrite  in ?b


module Vect
-- File referenced from Chapter4.idr

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

%name Vect xs, ys, zs

append : Vect n a -> Vect m a -> Vect (n + m) a
append [] ys = ys
append (x :: xs) ys = x :: append xs ys  -- <3<3<3 autocompleted

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

-- Fin n means a number that has an upper bound of n.
-- i.e. proof that the element < n
-- FZ : Fin n, for all n 0 < S n
-- FS (FZ) : proof that 1 < S (S n)
--   therefore FS : Fin n -> Fin (S n)
data Fin : Nat -> Type where
  FZ : Fin (S n)
  FS : Fin n -> Fin (S n)

index : Fin n -> Vect n a -> a
index FZ (x :: xs) = x
index (FS k) (x :: xs) = index k xs

natToFin : Nat -> (n : Nat) ->  Maybe (Fin n)
natToFin k Z = Nothing  -- Nothing is < 0
natToFin Z (S j) = Just FZ  -- Z < S n
natToFin (S k) (S j) = map FS (natToFin k j)  -- Functor example

integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)
integerToFin x Z = Nothing
integerToFin x (S k) = if x == 0 then Just FZ
                                 else map FS (integerToFin (x-1) k)  -- <3 Functors
-- Note to self: functor has map function and it's type is (a->b) -> f a -> f b
-- there is bit of missmatch between haskell: in hl map is of type (a->b) -> [a] -> [b]
-- fmap is the more general case.
-- If we look at https://hackage.haskell.org/package/base-4.12.0.0/docs/src/GHC.Base.html#line-966
-- we see fmap for [] is defined as map (so map is the primitive operation).

-- In the book we now go to TryIndex.idr where we import Data.Vect.
-- Given that we've already implemented integerToFin here, I'll just
-- continue in this file.
tryIndex : Integer -> Vect n a -> Maybe a
-- we want to go from x to Maybe Fin n to Maybe a
tryIndex {n} x xs = (map index (integerToFin x n)) <*> (Just xs)  -- Woot!
-- applicative takes a f (a->b) -> f a -> f b

tryIndex' : Integer -> Vect n a -> Maybe a
tryIndex' {n} x xs = map (flip index xs) (integerToFin x n) -- Woot2!

-- Return to Chapter4.idr


module GCD

data Divides : (d : Nat) -> (m : Nat) -> Type where
    FactorsWith : (d : Nat) -> (f : Nat) -> Divides d (d * f)

div_3_12 : Divides 3 12
div_3_12 = FactorsWith 3 4

total
testDivides : (d : Nat) -> (m : Nat) -> Bool
testDivides d Z = True
testDivides Z (S k) = False
testDivides (S d') (S k') = if (S d') > (S k') then False else testDivides (S d') (minus (S k') (S d'))

total
searchGCD_rec : Nat -> Nat -> Nat -> Nat
searchGCD_rec k j Z = Z--_1
searchGCD_rec k j (S d') = if testDivides (S d') k && testDivides (S d') j then (S d') else searchGCD_rec k j d'

total
searchGCD : Nat -> Nat -> Nat
searchGCD k j = searchGCD_rec k j k -- or j

-- total
-- euclid_rec : Nat -> Nat -> Nat -> Nat -> Nat
-- euclid_rec m n q r = if r >= n then euclid_rec m n (S q) (minus r n) else r

data IsPrime : (n : Nat) -> Type where
    NoDivisor : (d : Nat) -> (n : Nat) -> (Divides d (S n) -> Either (d = 1) (d = S n)) -> IsPrime (S n)

zeroNotPrime : Not (IsPrime Z)
zeroNotPrime (NoDivisor _ _ _) impossible

testPrime : (n : Nat) -> Dec (IsPrime n)
testPrime Z = No zeroNotPrime
testPrime (S n') = ?testPrime_rhs_2


module Bezout
import Divisors
import ZZ
import Data.Vect
import Data.Fin
%access public export

{-Copied from Chinmaya's code. Gives quotient and remainder on divison-}
{-This just computes the qoutient and the remainder, but it doesn't prove that they indeed satisfy the conditions a = b*q + r and r < b -}
Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat)
Eucl Z b = (Z,Z)
Eucl (S k) b = case (lte (S (S k)) b) of
                    False => (S(fst(Eucl (minus (S k) b) b)), snd(Eucl (minus (S k) b) b))
                    True => (Z, S k)
{-Just a slight modification of the Euclid's division function to give the remainder -}
rem : (a : Nat) -> (b : Nat) -> Nat
rem Z b = Z
rem (S k) b = case (lte (S (S k)) b) of
                    False => (rem (minus (S k) b) b)
                    True => (S k)
{-Let rk be the remainder in the Euclidean algorithm at the k-2th step.
Let rk = ak*r0 + bk*r1 where r0 and r1 are the original inputs.Correspondingly  rsk = ask*r0 + bsk*r1 where sk = k+1
Then the I am going to the next step in the Euclid algorithm and changing the coefficients.
These formulas can be easily derived.-}
Euclnos: (Integer,Integer,Integer,Integer,Integer,Integer)->(Integer,Integer,Integer,Integer,Integer,Integer)
Euclnos (rk, rsk ,ak ,ask, bk ,bsk) = (rsk,rssk,ask,assk,bsk,bssk) where
  rssk = cast(snd (Eucl (cast rk) (cast rsk)))
  bssk =bk-bsk* (cast(fst (Eucl (cast rk) (cast rsk))))
  assk =ak-ask* (cast(fst (Eucl (cast rk) (cast rsk))))
{-Does the Euclnos repeatedy until the remainder is zero. Then the previous remainder is the GCD.-}
Bezouttuple: (Integer,Integer,Integer,Integer,Integer,Integer)->(Integer,Integer,Integer,Integer,Integer,Integer)
Bezouttuple (rk, rsk ,ak ,ask, bk, bsk) = case rsk of
                                        0 => (rk, rsk, ak, ask, bk, bsk)
                                        _ => (Bezouttuple (Euclnos (rk ,rsk, ak ,ask ,bk ,bsk)))
{-Returns 2 particular Integers out of a 6 tuple-}
returnab: (Integer,Integer,Integer,Integer,Integer,Integer)->(ZZ,ZZ)
returnab (a ,b ,c ,d, e ,f)  = (cast c,cast e)
{-Returns the Bezout coefficients-}
Bezout : Nat ->Nat ->(ZZ,ZZ)
Bezout k j =  (returnab(Bezouttuple((cast k) , (cast j),1, 0 ,0 ,1)))

|||Same as Euclnos wxcept that it stores the quotient and remainder in a list
MEuclnos:((Integer,Integer,Integer,Integer,Integer,Integer),(List (Integer,Integer)))->((Integer,Integer,Integer,Integer,Integer,Integer),(List (Integer,Integer)))
MEuclnos ((rk, rsk ,ak ,ask, bk ,bsk),xs) = ((Euclnos (rk, rsk ,ak ,ask, bk ,bsk)),((q,r)::xs)) where
  q = (cast(fst (Eucl (cast rk) (cast rsk))))
  r = (cast(snd (Eucl(cast rk) (cast rsk))))
|||Same as Bezouttuple except that it stores the quotient and remainder in a list
MBezout:((Integer,Integer,Integer,Integer,Integer,Integer),(List (Integer,Integer)))->((Integer,Integer,Integer,Integer,Integer,Integer),(List (Integer,Integer)))
MBezout ((rk, rsk ,ak ,ask, bk ,bsk),xs) = case rsk of
                                                0 =>  ((rk, rsk ,ak ,ask, bk ,bsk),xs)
                                                _ =>MBezout (MEuclnos ((rk, rsk ,ak ,ask, bk ,bsk),xs))

|||Gives a list of quotients and remainders in Euclid's Algorithm
EuclList:(a:Nat)->(b:Nat)->List (Integer,Integer)
EuclList a b = (snd (MBezout (((cast a)  ,(cast b), 1,0,0,1),[])))

gcd2 : Nat -> Nat -> ZZ
gcd2 a b = ( (((cast a)*(snd (Bezout a b))) + ((cast b)*(fst (Bezout a b)))))

{-}
just the functions to compute the GCD in two different ways.
{-}
{-
gcd2 : Nat -> Nat -> ZZ
gcd2 a b = ( (((cast a)*(snd (Bezout a b))) + ((cast b)*(fst (Bezout a b)))))

gcdab : Nat -> Nat -> Nat
gcdab b Z = b
gcdab a b = gcdab b (snd (Eucl a b))

{-}

{-proof of existence of remainders and quotients is necessary to define the concept of divisibilty -}
{-The next step ahead might be to proof the uniqueness of these remainders and quotients probably -}

-- defining divisibilty as b | a if there exists q such that a = b*q + Z
-- if b | a and c | b, then c | a.
-- if c | a and c | b, then c | (a + b)

-- auxplusDiv 1 to 4 are just auxilary proofs.
auxtransDiv : (a : Nat) -> (b : Nat) -> (c : Nat) -> (d : Nat) -> (b = c*q)
auxtransDiv a b c d = ?auxtransDiv_rhs

auxplusDiv1 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (d : Nat) -> (a = b) -> (c = d) -> (a + c = b + d)
auxplusDiv1 b b d d Refl Refl = Refl

auxplusDiv2 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (q : Nat) -> (p : Nat) -> (a = c*q) -> (b = c*p) -> (a + b = c*(q + p))
auxplusDiv2 a b c q p pf1 pf2 = (trans (auxplusDiv1 a (c*q) b (c*p) pf1 pf2) (sym(multDistributesOverPlusRight c q p)))

auxplusDiv3 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (d : Nat) -> (a = c) -> (b = d) -> ((minus a b) = (minus c d))
auxplusDiv3 c d c d Refl Refl = Refl

-- Holes !!
auxplusDiv4 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (q : Nat) -> (p : Nat) -> (a + b = c*q) -> (b = c*p) -> (a = c*(minus q p))
auxplusDiv4 a b c q p pf1 pf2 = ?auxplusDiv3_rhs

--These statements are the two main facts we might be Integererested in.
plusDiv1 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (q : Nat ** a = c*q) -> (p : Nat ** b = c*p) -> (f : Nat ** a + b = c*f)
plusDiv1 a b c (q ** pf1) (p ** pf2) = ((q + p) ** (auxplusDiv2 a b c q p pf1 pf2))

plusDiv2 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (q : Nat ** a + b = c*q) -> (p : Nat ** b = c*p) -> (f : Nat ** a = c*f)
plusDiv2 a b c (q ** pf1) (p ** pf2) = ((minus q p) ** (auxplusDiv4 a b c q p pf1 pf2))

-- I'll try and prove some (possibly useful) facts about the gcd.
-- weak definition of the gcd : d | a, d | b and if c | a and c | b, then c <= d.
--This is the common Factor Type

isCommonFactor : Nat -> Nat -> Nat -> Type
isCommonFactor a b c = ((q : Nat ** a = c*q),(p : Nat ** b = c*p))

--This is the GCD type
-- d is "a" gcd of a and b if isGCD a b d type is inhabited.
-- Uniqueness of GCD not assumed !!
-- the gcd is just assumed to be bigger than any other common divisor, not a multiple of it.

isGCD : Nat -> Nat -> Nat -> Type
isGCD a b d = ((isCommonFactor a b d) , ((c : Nat) -> (isCommonFactor a b c) -> (LTE c d)))

-- try to prove that if d is "a" gcd of (a,b) then it is "a" gcd of (a+b,a)

gcdfact1 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD a b d) -> (isCommonFactor (a + b) b d)
gcdfact1 a b d (((q ** pf1),(p ** pf2)),f) = ((plusDiv1 a b d (q ** pf1) (p ** pf2)),(p ** pf2))

gcdfact2 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD a b d) -> (c : Nat) -> (isCommonFactor (a + b) b c) -> (LTE c d)
gcdfact2 a b d (pf , f) c ((q ** pf1),(p ** pf2)) = (f c ((plusDiv2 a b c (q ** pf1) (p ** pf2)),(p ** pf2)))

maingcdfact1 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD a b d) -> (isGCD (a + b) b d)
maingcdfact1 a b d pf = ((gcdfact1 a b d pf),(gcdfact2 a b d pf))

-- now the proof that if d is "a" gcd of (a+b,b), then it is "a" gcd of (a,b)

gcdfact3 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD (a + b) b d) -> (isCommonFactor a b d)
gcdfact3 a b d (((q ** pf1),(p ** pf2)),f) = ((plusDiv2 a b d (q ** pf1) (p ** pf2)),(p ** pf2))

gcdfact4 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD (a + b) b d) -> (c : Nat) -> (isCommonFactor a b c) -> (LTE c d)
gcdfact4 a b d (pf, f) c ((q ** pf1),(p ** pf2)) = (f c ((plusDiv1 a b c (q ** pf1) (p ** pf2)),(p ** pf2)))

maingcdFact2 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD (a + b) b d) -> (isGCD a b d)
maingcdFact2 a b d pf = ((gcdfact3 a b d pf),(gcdfact4 a b d pf))

-- now the proof that if d is "a" gcd of (a,b), it is also "a" gcd of (b,a)

symCommonFactor : (a : Nat) -> (b : Nat) -> (c : Nat) -> (isCommonFactor a b c) -> (isCommonFactor b a c)
symCommonFactor a b c ((p ** pf1),(q ** pf2)) = ((q ** pf2),(p ** pf1))

symGCD1 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD a b d) -> ((c : Nat) -> (isCommonFactor b a c) -> (LTE c d))
symGCD1 a b d (pf, f) = g where
                          g c ((p ** pf1),(q ** pf2)) = f c ((q ** pf2),(p ** pf1))

symGCD : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD a b d) -> (isGCD b a d)
symGCD a b d (pf , f) = ((symCommonFactor a b d pf) , (symGCD1 a b d (pf , f)))

-- I'll list the types and functions that might be useful
-- The GCD type : isGCD : Nat -> Nat -> Nat -> Type
--                isGCD a b d = ((isCommonFactor a b d) , ((c : Nat) -> (isCommonFactor a b c) -> (LTE c d)))
-- maingcdfact1 , maingcdfact2 , symGCD.

-- The next step might be to show that the natural number that the euclidian algorithm gives us is indeed a gcd
-- also uniqueness of gcd.


module Tools.NatUtils

%access public export

-- Proof of the type that an implication implies its contrapositive
impliesContrapositive : (A : Type) -> (B : Type) -> (A -> B) -> (B -> Void) -> (A -> Void)
impliesContrapositive typeA typeB proofAimpliesB proofBfalse a = proofBfalse (proofAimpliesB a)

-- Proof that S m = S n implies m = n
meqnSmeqSn : (m : Nat) -> (n : Nat) -> (S m = S n) -> (m = n)
meqnSmeqSn Z Z Refl = Refl
meqnSmeqSn (S k) (S k) Refl = Refl

-- Proof that m = n implies f(m) = f(n), taken from Lecture.intro (apNat)
functionExtendEquality : (f : Nat -> Nat) -> (n : Nat) -> (m : Nat) -> (n = m) -> (f n = f m)
functionExtendEquality f m m Refl = Refl

-- Proof that m != n implies S m != S n
proofSmneqSn : (m : Nat) -> (n : Nat) -> ((m = n) -> Void) -> ((S m = S n) -> Void)
proofSmneqSn m n proofmneqn = impliesContrapositive (S m = S n) (m = n) (meqnSmeqSn m n) proofmneqn

-- Proof that m<n implies S m = n or S m < n
proofLTimplieseqorLT : (m : Nat) -> (n : Nat) -> (LT m n) -> Either (S m = n) (LT (S m) n)
proofLTimplieseqorLT Z (S Z) (LTESucc LTEZero) = Left Refl
proofLTimplieseqorLT Z (S (S n)) (LTESucc LTEZero) = Right (LTESucc (LTESucc LTEZero))
proofLTimplieseqorLT (S m) (S n) proofSmLTSn = case (proofLTimplieseqorLT m n (fromLteSucc proofSmLTSn)) of
										(Left proofSmeqn) => Left (functionExtendEquality S (S m) n proofSmeqn)
										(Right proofSmLTn) => Right (LTESucc proofSmLTn)

|||The theorem that (m<=n) and (n<=m) implies n=m
lteAndGteImpliesEqual:{m:Nat}-> {n:Nat}->(LTE m n)-> (LTE n m)->(n=m)
lteAndGteImpliesEqual LTEZero LTEZero = Refl
lteAndGteImpliesEqual (LTESucc x) (LTESucc y) = cong (lteAndGteImpliesEqual x y)
|||The theorem (m<=n) implies (m<=(c+n))
plusConstantLeftSide:{m:Nat}->{n:Nat}->(c:Nat)->LTE m n ->LTE m (c+n)
plusConstantLeftSide Z x = x
plusConstantLeftSide (S k) x = lteSuccRight (plusConstantLeftSide k x)

plusConstantLeftPreservesLte:{m:Nat}-> {n:Nat}->(c:Nat)->(LTE m n)->(LTE (c+m) (c+n))
plusConstantLeftPreservesLte Z x = x
plusConstantLeftPreservesLte (S k) x = LTESucc (plusConstantLeftPreservesLte k x)

plusConstantRightPreservesLte:{m:Nat}-> {n:Nat}->(c:Nat)->(LTE m n)->(LTE (m+c) (n+c))
plusConstantRightPreservesLte {m}{n}c x = rewrite (plusCommutative m c)  in (rewrite (plusCommutative n c) in (plusConstantLeftPreservesLte c x))

|||The theorem that for any natural numbers k and m (m<= (S k)*m)
natLteMultNatNat: (k:Nat)->(m:Nat)->(LTE m ((S k)*m))
natLteMultNatNat Z m = rewrite (multOneLeftNeutral m) in (lteRefl)
natLteMultNatNat (S k) m =     plusConstantLeftSide m (natLteMultNatNat  k m)


module CaseAnalysis

import Booleans
import Bltnat

-- By using the commumative property of (+) it is easiest just to write (n + 1) as (1 + n) as beq_nat and (+) pattern match on the 1st argument, thus it can't be an unknown
plusft_com : (n : Nat) -> beq_nat (1 + n) 0 = False
plusft_com n = Refl

-- Or case split on the original
plusft : (n : Nat) -> beq_nat (n + 1) 0 = False
plusft Z = Refl
plusft (S k) = Refl

andb_commutative : (b, c : Bool) -> andb b c = andb c b
andb_commutative False False = Refl
andb_commutative False True = Refl
andb_commutative True False = Refl
andb_commutative True True = Refl

-- Alternative
andbcommutative'rhs_1 : (c : Bool) -> False = andb c False
andbcommutative'rhs_1 False = Refl
andbcommutative'rhs_1 True = Refl

andbcommutative'rhs_2 : (c : Bool) -> c = andb c True
andbcommutative'rhs_2 False = Refl
andbcommutative'rhs_2 True = Refl

andbCommutative : (b, c : Bool) -> andb b c = andb c b
andbCommutative False = andbcommutative'rhs_1
andbCommutative True = andbcommutative'rhs_2

-- Exercise 9.1
andbTelim2F : (c : Bool) -> (prf : andb False c = True) -> c = True
andbTelim2F False prf = prf
andbTelim2F True prf = Refl

andbTelim2T : (c : Bool) -> (prf : andb True c = True) -> c = True
andbTelim2T False prf = prf
andbTelim2T True prf = Refl

andbTelim2 : (b, c : Bool) -> (andb b c = True) -> c = True
andbTelim2 False c prf = andbTelim2F c prf
andbTelim2 True c prf = andbTelim2T c prf

-- Exercise 9.2
zeroNbeqPlusZ : False = False
zeroNbeqPlusZ = Refl

zeroNbeqPlus1S : (k : Nat) -> False = False
zeroNbeqPlus1S k = Refl

zeroNbeqPlus1 : (n : Nat) -> beq_nat 0 (n + 1) = False
zeroNbeqPlus1 Z = zeroNbeqPlusZ
zeroNbeqPlus1 (S k) = zeroNbeqPlus1S k


module OddAndEvens

%access export
%default total

public export
data Even : Nat -> Type where
  -- | Zero is even.
  ZeroEven : Even Z
  -- | If n is even, then n+2 is even.
  NextEven : Even n -> Even (S (S n))

public export
data Odd : Nat -> Type where
  -- | One is odd.
  OneOdd : Odd (S Z)
  -- | If n is odd, then n+2 is odd.
  NextOdd : Odd n -> Odd (S (S n))

-- | Proves that if n is even, n+1 is odd.
-- Notice how I use the axioms here.
evenPlusOne : Even n -> Odd (S n)
evenPlusOne  ZeroEven    = OneOdd
evenPlusOne (NextEven x) = NextOdd $ evenPlusOne x

-- | Proves that if n is odd, n+1 is even.
oddPlusOne : Odd n -> Even (S n)
oddPlusOne  OneOdd     = NextEven $ ZeroEven
oddPlusOne (NextOdd x) = NextEven $ oddPlusOne x

-- | Proves even + even = even
evenPlusEven : Even n -> Even m -> Even (n + m)
evenPlusEven  ZeroEven    y = y
evenPlusEven (NextEven x) y = NextEven $ evenPlusEven x y

-- | Proves odd + odd = even
oddPlusOdd : Odd n -> Odd m -> Even (n + m)
oddPlusOdd OneOdd      y = oddPlusOne y
oddPlusOdd (NextOdd x) y = NextEven $ oddPlusOdd x y

-- | Proves even + odd = odd
evenPlusOdd : Even n -> Odd m -> Odd (n + m)
evenPlusOdd ZeroEven     y = y
evenPlusOdd (NextEven x) y = NextOdd $ evenPlusOdd x y

-- | Proves odd + even = odd
oddPlusEven : Odd n -> Even m -> Odd (n + m)
oddPlusEven OneOdd      y = evenPlusOne y
oddPlusEven (NextOdd x) y = NextOdd $ oddPlusEven x y

-- | Proves even * even = even
evenTimesEven : Even n -> Even m -> Even (n * m)
evenTimesEven ZeroEven     _ = ZeroEven
evenTimesEven (NextEven x) y = evenPlusEven y $ evenPlusEven y $ evenTimesEven x y

-- | Proves odd * odd = odd
oddTimesOdd : Odd n -> Odd m -> Odd (n * m)
oddTimesOdd OneOdd {m}  y = rewrite plusZeroRightNeutral m in y
oddTimesOdd (NextOdd x) y = oddPlusEven y $ oddPlusOdd y $ oddTimesOdd x y

-- | Proves even * odd = even
evenTimesOdd : Even n -> Odd m -> Even (n * m)
evenTimesOdd ZeroEven y = ZeroEven
evenTimesOdd (NextEven x) y = oddPlusOdd y $ oddPlusEven y $ evenTimesOdd x y

-- | Proves odd * even = even
oddTimesEven : Odd n -> Even m -> Even (n * m)
oddTimesEven OneOdd {m}  y = rewrite plusZeroRightNeutral m in y
oddTimesEven (NextOdd x) y = evenPlusEven y $ evenPlusEven y $ oddTimesEven x y


module AssRecRule

import Data.Fin
import Data.Vect

%default total

||| 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 ty1 ty2 elem fun Nil = elem
recList ty1 ty2 elem fun (x :: xs) = (fun x xs (recList ty1 ty2 elem fun 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 ty1 ty2 f = recList ty1 (List ty2) Nil fun where

    fun : ty1 -> (List ty1) -> (List ty2) -> (List ty2)
    fun x xs ys = (f x) :: ys

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

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

foldList : (a : Type) ->  (init : a) -> (op : a -> a -> a) -> List a -> a

foldList ty init op = recList ty ty init fun where
    fun : ty -> (List ty) -> ty -> ty
    fun x xs y = (op x y) -- it can be defined as (op y x) also depending on the need

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

||| 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 Z k impossible
inducFin xs base step (S q) FZ = base q
inducFin xs base step (S Z) (FS k) impossible
inducFin xs base step (S (S q)) (FS k) = step (S q) k (inducFin xs base step (S q) k)

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

||| 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 `inducFin` and without pattern matching on the `Fin` family. You may pattern match on Vectors.

fetchElem : (a: Type) -> (q: Nat) -> (j: Fin q) -> (Vect q a -> a)

fetchElem ty q j = inducFin family base step q j where

    family : (n : Nat) -> (Fin n) -> Type
    family n k = (Vect n ty) -> ty

    base : (m : Nat) -> (family (S m) FZ)
    base m (x :: xs) = x

    step : (p : Nat) -> (k : Fin p) -> (prev : (family p k)) -> (family (S p) (FS k))
    step p k prev (x :: xs) = prev xs


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 base step [] = base
recList a x base step (y :: ys) = step y ys (recList a x base step ys)

{-
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 x = recList a (List b) [] step x where
  step = \y : a => \ys : List a => \result : List b => (f y) :: result

{-
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.
-}
foldList : (a: Type) ->  (init: a) -> (op : a -> a -> a) -> List a -> a
foldList a init op y = recList a a init step y where
  step = \y : a => \ys : List a => \result : a => op y result

{-
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 _ _ _ Z FZ impossible
inducFin _ _ _ Z FS impossible
inducFin xs base step (S k) FZ = base k
inducFin xs base step (S k) (FS j) = step k j (inducFin xs base step k j)

{-
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 v = inducFin xs base step q j v where
  xs : (n : Nat) -> Fin n -> Type
  xs q j = Vect q a -> a
  base : (m : Nat) -> xs (S m) FZ
  base m = f where
    f (x :: xs) = x
  step : (p : Nat) -> (k : Fin p) -> (prev : xs p k) -> (xs (S p) (FS k))
  step p k prev (y :: ys) = prev ys


module Chapter2

import Data.List
import Data.Nat

%default total

-- Exercise 2.2

export
add_assoc : (n, m, k : Nat) -> n + (m + k) = (n + m) + k
add_assoc Z     m k = Refl
add_assoc (S n) m k = rewrite add_assoc n m k in Refl

add_z_right : (n : Nat) -> n + 0 = n
add_z_right Z     = Refl
add_z_right (S n) = rewrite add_z_right n in Refl

add_s_right : (n, m : Nat) -> n + S m = S (n + m)
add_s_right Z     m = Refl
add_s_right (S n) m = rewrite add_s_right n m in Refl

export
add_comm : (n, m : Nat) -> n + m = m + n
add_comm Z     m = rewrite add_z_right m in Refl
add_comm (S n) m = rewrite add_comm n m in
                   rewrite add_s_right m n in
                   Refl

public export
double : Nat -> Nat
double Z     = Z
double (S n) = S . S $ double n

export
double_is_add : (m : Nat) -> double m = m + m
double_is_add Z     = Refl
double_is_add (S m) = rewrite double_is_add m in
                      rewrite add_s_right m m in
                      Refl

-- Exercise 2.3

public export
count : Eq a => a -> List a -> Nat
count _ []      = 0
count x (y::xs) = if x == y
                    then S $ count x xs
                    else count x xs

export
count_le_length : Eq a => (x : a) -> (xs : List a) -> count x xs `LTE` length xs
count_le_length x []      = LTEZero
count_le_length x (y::xs) with (x == y)
  count_le_length x (_::xs) | True  = LTESucc $ count_le_length x xs
  count_le_length x (_::xs) | False = lteSuccRight $ count_le_length x xs

-- Exercise 2.4

public export
snoc : List a -> a -> List a
snoc [] n      = [n]
snoc (x::xs) n = x :: Chapter2.snoc xs n

public export
reverse : List a -> List a
reverse []      = []
reverse (x::xs) = Chapter2.snoc (Chapter2.reverse xs) x

reverse_of_snoc : (xs : List a) -> (x : a) -> Chapter2.reverse (Chapter2.snoc xs x) = x :: Chapter2.reverse xs
reverse_of_snoc [] _      = Refl
reverse_of_snoc (_::xs) n = rewrite reverse_of_snoc xs n in Refl

export
double_reverse : (xs : List a) -> Chapter2.reverse (Chapter2.reverse xs) = xs
double_reverse []      = Refl
double_reverse (x::xs) = rewrite reverse_of_snoc (Chapter2.reverse xs) x in
                         rewrite double_reverse xs in
                         Refl

-- Exercise 2.5

public export
sum_upto : Nat -> Nat
sum_upto Z     = Z
sum_upto (S n) = S n + sum_upto n

export
half : Nat -> Nat
half Z         = Z
half (S Z)     = Z
half (S (S n)) = S (half n)

half_of_add : (a : Nat) -> (n : Nat) -> a + half n = half (a + (a + n))
half_of_add Z     n = Refl
half_of_add (S k) n = rewrite sym $ plusSuccRightSucc k (k + n) in
                      rewrite half_of_add k n in
                      Refl

-- Contents of standard `Nat`'s `div` are not enclosed (somewhy), that's why I defined my own recusrive `half`.
public export
sum_upto_formula : (n : Nat) -> sum_upto n = half (n * (n + 1))
sum_upto_formula Z     = Refl
sum_upto_formula (S k) = rewrite sum_upto_formula k in
                         rewrite plusCommutative k 1 in
                         rewrite multRightSuccPlus k (S k) in
                         rewrite half_of_add k (k * S k) in
                         Refl

-- Exercise 2.6

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

public export
contents : Tree a -> List a
contents Tip          = []
contents (Node l x r) = x :: contents l ++ contents r

public export
sum_tree : Tree Nat -> Nat
sum_tree Tip          = 0
sum_tree (Node l x r) = x + sum_tree l + sum_tree r

-- We could do this for `Num a => ... List a` asap `Num` would contain the monoid rules (zero elimintation, etc.)
sum_of_concat : (xs, ys : List Nat) -> sum (xs ++ ys) = sum xs + sum ys
sum_of_concat [] ys = rewrite plusZeroLeftNeutral (sum ys) in Refl
sum_of_concat (x::xs) ys = rewrite sum_of_concat xs ys in
                           rewrite plusAssociative x (sum xs) (sum ys) in
                           Refl

export
sum_tree_thru_contents : (tr : Tree Nat) -> sum_tree tr = sum (contents tr)
sum_tree_thru_contents Tip          = Refl
sum_tree_thru_contents (Node l x r) = rewrite sum_tree_thru_contents l in
                                      rewrite sum_tree_thru_contents r in
                                      rewrite sum_of_concat (contents l) (contents r) in
                                      rewrite plusAssociative x (sum $ contents l) (sum $ contents r) in
                                      Refl

-- Exercise 2.7

namespace Ex_2_7

  public export
  data Tree2 a = Tip
               | Leaf a
               | Node (Tree2 a) a (Tree2 a)

public export
mirror : Tree2 a -> Tree2 a
mirror n@Tip        = n
mirror n@(Leaf _)   = n
mirror (Node l x r) = Node (mirror r) x (mirror l)

mirror_of_mirror : (t : Tree2 a) -> mirror (mirror t) = t
mirror_of_mirror Tip          = Refl
mirror_of_mirror (Leaf _)     = Refl
mirror_of_mirror (Node l _ r) = rewrite mirror_of_mirror l in
                                rewrite mirror_of_mirror r in
                                Refl

public export
pre_order : Tree2 a -> List a
pre_order Tip          = []
pre_order (Leaf x)     = [x]
pre_order (Node l x r) = x :: pre_order l ++ pre_order r

public export
post_order : Tree2 a -> List a
post_order Tip          = []
post_order (Leaf x)     = [x]
post_order (Node l x r) = post_order l ++ post_order r ++ [x]

export
pre_n_post_orders : (t : Tree2 a) -> pre_order (mirror t) = Data.List.reverse (post_order t)
pre_n_post_orders Tip          = Refl
pre_n_post_orders (Leaf _)     = Refl
pre_n_post_orders (Node l x r) = rewrite pre_n_post_orders l in
                                 rewrite pre_n_post_orders r in
                                 rewrite sym $ revAppend (post_order l) (post_order r ++ [x]) in
                                 rewrite sym $ revAppend (post_order r) [x] in
                                 Refl

-- Exercise 2.8

public export
intersperse : a -> List a -> List a
intersperse _ []            = []
intersperse _ [x]           = [x]
intersperse s (x::r@(_::_)) = x :: s :: Chapter2.intersperse s r
-- The line above can be written simpler, as `intersperse s (x::y::ys) = x :: s :: Chapter2.intersperse s (y::ys)`
--   but actual definitely does not rebuild the `r`, but simpler one may rebuild this in runtime (thus, less may be effective).

export
intersperse_n_map : (s : a) -> (xs : List a) -> (f : a -> a) -> map f (Chapter2.intersperse s xs) = Chapter2.intersperse (f s) (map f xs)
intersperse_n_map s []            f = Refl
intersperse_n_map s [x]           f = Refl
intersperse_n_map s (x::r@(_::_)) f = rewrite intersperse_n_map s r f in Refl

-- Exercise 2.9

public export
itadd : Nat -> Nat -> Nat
itadd Z     m = m
itadd (S n) m = itadd n (S m)

export
itadd_is_add : (n, m : Nat) -> itadd n m = n + m
itadd_is_add Z     m = Refl
itadd_is_add (S n) m = rewrite itadd_is_add n (S m) in
                       rewrite plusSuccRightSucc n m in
                       Refl

-- Exercise 2.10

namespace Ex_2_10

  public export
  data Tree0 = Tip | Node Tree0 Tree0

public export
nodes : Tree0 -> Nat
nodes Tip        = 1
nodes (Node l r) = nodes l + nodes r + 1

public export
explode : Nat -> Tree0 -> Tree0
explode Z     t = t
explode (S n) t = explode n $ Node t t

export
explode_in_nodes : (n : Nat) -> (t : Tree0) -> nodes (explode n t) = ((2 `power` n) * nodes t + (2 `power` n)) `minus` 1
explode_in_nodes Z t = rewrite plusZeroRightNeutral $ nodes t in
                       rewrite plusCommutative (nodes t) 1 in
                       rewrite minusZeroRight $ nodes t in
                       Refl
explode_in_nodes (S n) t = rewrite explode_in_nodes n (Node t t) in
                           rewrite plusZeroRightNeutral $ 2 `power` n in
                           rewrite plusCommutative (nodes t + nodes t) 1 in
                           rewrite multRightSuccPlus (power 2 n) (nodes t + nodes t) in
                           rewrite plusCommutative (power 2 n) $ power 2 n * (nodes t + nodes t) in
                           rewrite sym $ plusAssociative (power 2 n * (nodes t + nodes t)) (power 2 n) (power 2 n) in
                           rewrite multDistributesOverPlusRight (power 2 n) (nodes t) (nodes t) in
                           rewrite multDistributesOverPlusLeft (power 2 n) (power 2 n) (nodes t) in
                           Refl

-- Exercise 2.11

-- Original `Int` was replaces with `Int` because where are not enough rules for `Int`s.

public export
data Exp = Var
         | Const Nat
         | Add Exp Exp
         | Mult Exp Exp

public export
eval : Exp -> Nat -> Nat
eval Var        x = x
eval (Const n)  _ = n
eval (Add l r)  x = eval l x + eval r x
eval (Mult l r) x = eval l x * eval r x

public export
evalp : Num a => List a -> a -> a
evalp []      _ = 0
evalp (p::ps) x = p + x * evalp ps x

infixr 8 +|+
public export
(+|+) : Num a => List a -> List a -> List a
[]      +|+ r       = r
l       +|+ []      = l
(l::ls) +|+ (r::rs) = l+r :: ls +|+ rs

export
evalp_add_lin : (l, r : List Nat) -> (x : Nat) -> evalp (l +|+ r) x = evalp l x + evalp r x
evalp_add_lin [] r x = Refl
evalp_add_lin l@(_::_) [] x = rewrite plusZeroRightNeutral (evalp l x) in Refl
evalp_add_lin (l::ls) (r::rs) x = rewrite evalp_add_lin ls rs x in
                                  rewrite multDistributesOverPlusRight x (evalp ls x) (evalp rs x) in
                                  rewrite replus l r (mult x (evalp ls x)) (mult x (evalp rs x)) in
                                  Refl
  where
    replus : (l, r, p, q : Nat) -> (l + r) + (p + q) = (l + p) + (r + q)
    replus l r p q = rewrite sym $ plusAssociative l r (p + q) in
                     rewrite plusCommutative p q in
                     rewrite plusAssociative r q p in
                     rewrite plusCommutative (r + q) p in
                     rewrite plusAssociative l p (r + q) in
                     Refl

infixr 9 *|*
public export
(*|*) : Num a => List a -> List a -> List a
[]      *|* _       = []
_       *|* []      = []
(l::ls) *|* (r::rs) = l*r :: (0 :: ls *|* rs) +|+ map (*l) rs +|+ map (*r) ls

evalp_map : (n : Nat) -> (ns : List Nat) -> (x : Nat) -> evalp (map (*n) ns) x = n * evalp ns x
evalp_map n [] x = rewrite multZeroRightZero n in Refl
evalp_map n (m::ms) x = rewrite evalp_map n ms x in
                        rewrite multAssociative x n (evalp ms x) in
                        rewrite multCommutative x n in
                        rewrite multCommutative m n in
                        rewrite multDistributesOverPlusRight n m (x * evalp ms x) in
                        rewrite multAssociative n x (evalp ms x) in
                        Refl

export
evalp_mul_lin : (l, r : List Nat) -> (x : Nat) -> evalp (l *|* r) x = evalp l x * evalp r x
evalp_mul_lin [] r x = Refl
evalp_mul_lin l@(_::_) [] x = rewrite multZeroRightZero (evalp l x) in Refl
evalp_mul_lin (l::ls) (r::rs) x = rewrite evalp_add_lin (0 :: ls *|* rs) (map (*l) rs +|+ map (*r) ls) x in
                                  rewrite evalp_add_lin (map (*l) rs) (map (*r) ls) x in
                                  rewrite evalp_mul_lin ls rs x in
                                  rewrite evalp_map r ls x in
                                  rewrite evalp_map l rs x in
                                  rewrite remult l r (evalp ls x) (evalp rs x) x in
                                  Refl
  where
    remult : (l, r, el, er, x : Nat) -> (l + x*el) * (r + x*er) = l*r + x*(x*(el*er) + (l*er + r*el))
    remult l r el er x =                                                                           -- (l + x*el) * (r + x*er)
                         rewrite multDistributesOverPlusLeft l (x*el) (r + x*er) in                -- l * (r + x*er) + (x*el)*(r + x*er)
                         rewrite multDistributesOverPlusRight l r (x*er) in                        -- (l*r + l*(x*er)) + (x*el)*(r + x*er)
                         rewrite multDistributesOverPlusRight (x*el) r (x*er) in                   -- (l*r + l*(x*er)) + ((x*el)*r + (x*el)*(x*er))
                         rewrite multAssociative l x er in                                         -- (l*r + (l*x)*er) + ((x*el)*r + (x*el)*(x*er))
                         rewrite multCommutative l x in                                            -- (l*r + (x*l)*er) + ((x*el)*r + (x*el)*(x*er))
                         rewrite sym $ multAssociative x l er in                                   -- (l*r + x*(l*er)) + ((x*el)*r + (x*el)*(x*er))
                         rewrite sym $ multAssociative x el r in                                   -- (l*r + x*(l*er)) + (x*(el*r) + (x*el)*(x*er))
                         rewrite sym $ multAssociative x el (x*er) in                              -- (l*r + x*(l*er)) + (x*(el*r) + x*(el*(x*er)))
                         rewrite multAssociative el x er in                                        -- (l*r + x*(l*er)) + (x*(el*r) + x*((el*x)*er))
                         rewrite multCommutative el x in                                           -- (l*r + x*(l*er)) + (x*(el*r) + x*((x*el)*er))
                         rewrite sym $ multAssociative x el er in                                  -- (l*r + x*(l*er)) + (x*(el*r) + x*(x*(el*er)))
                         rewrite multCommutative el r in                                           -- (l*r + x*(l*er)) + (x*(r*el) + x*(x*(el*er)))
                         rewrite sym $ multDistributesOverPlusRight x (r*el) (x*(el*er)) in        -- (l*r + x*(l*er)) + x*(r*el + x*(el*er))
                         rewrite plusCommutative (r*el) (x*(el*er)) in                             -- (l*r + x*(l*er)) + x*(x*(el*er) + r*el)
                         rewrite sym $ plusAssociative (l*r) (x*(l*er)) (x*(x*(el*er) + r*el)) in  -- l*r + (x*(l*er) + x*(x*(el*er) + r*el))
                         rewrite sym $ multDistributesOverPlusRight x (l*er) (x*(el*er) + r*el) in -- l*r + x*(l*er + (x*(el*er) + r*el))
                         rewrite plusAssociative (l*er) (x*(el*er)) (r*el) in                      -- l*r + x*((l*er + x*(el*er)) + r*el)
                         rewrite plusCommutative (l*er) (x*(el*er)) in                             -- l*r + x*((x*(el*er) + l*er) + r*el)
                         rewrite sym $ plusAssociative (x*(el*er)) (l*er) (r*el) in                -- l*r + x*(x*(el*er) + (l*er + r*el))
                         Refl

public export
coeffs : Exp -> List Nat
coeffs Var        = [0, 1]
coeffs (Const n)  = [n]
coeffs (Add l r)  = coeffs l +|+ coeffs r
coeffs (Mult l r) = coeffs l *|* coeffs r

export
evalp_of_coeffs_is_eval : (e : Exp) -> (x : Nat) -> evalp (coeffs e) x = eval e x
evalp_of_coeffs_is_eval Var x = rewrite multZeroRightZero x in
                                rewrite multOneRightNeutral x in
                                Refl
evalp_of_coeffs_is_eval (Const n) x = rewrite multZeroRightZero x in
                                      rewrite plusZeroRightNeutral n in
                                      Refl
evalp_of_coeffs_is_eval (Add l r) x = rewrite evalp_add_lin (coeffs l) (coeffs r) x in
                                      rewrite evalp_of_coeffs_is_eval l x in
                                      rewrite evalp_of_coeffs_is_eval r x in
                                      Refl
evalp_of_coeffs_is_eval (Mult l r) x = rewrite evalp_mul_lin (coeffs l) (coeffs r) x in
                                       rewrite evalp_of_coeffs_is_eval l x in
                                       rewrite evalp_of_coeffs_is_eval r x in
                                       Refl


data Divisibleby3 : Nat -> Type where
  Three: Divisibleby3 3
  ThreeMultiple: Divisibleby3 x -> Divisibleby3 (3+x)

divBy9: Divisibleby3 9
divBy9 = ThreeMultiple (ThreeMultiple Three)

data DivisiblebyX : Nat -> Nat -> Type where
  Base:DivisiblebyX x x
  Multiple: DivisiblebyX x y -> DivisiblebyX x (x+y)

divBy5_15: DivisiblebyX 5 15
divBy5_15 = Multiple (Multiple Base)

divBy3_15: DivisiblebyX 3 15
divBy3_15 = Multiple (Multiple (Multiple (Multiple Base)))

data FizzBuzzProofSimple: Nat -> Type where
  Fizz: DivisiblebyX 3 x -> FizzBuzzProofSimple x
  Buzz: DivisiblebyX 5 x -> FizzBuzzProofSimple x
  FizzBuzz: DivisiblebyX 3 x -> DivisiblebyX 5 x -> FizzBuzzProofSimple x
  Normal: (x: Nat) -> FizzBuzzProofSimple x

Show (FizzBuzzProofSimple x) where
  show (Fizz _) = "fizz"
  show (Buzz _) = "buzz"
  show (FizzBuzz _ _) = "fizzbuzz"
  show (Normal x) = show x

proof5: FizzBuzzProofSimple 5
proof5 = Buzz Base

proof3: FizzBuzzProofSimple 3
proof3 = Fizz Base

proof7: FizzBuzzProofSimple 7
proof7 = Normal 7

proof15: FizzBuzzProofSimple 15
proof15 = FizzBuzz (Multiple (Multiple (Multiple (Multiple Base)))) (Multiple (Multiple Base))

divisibleby3: (y: Nat) -> Maybe (DivisiblebyX 3 y)
divisibleby3  (S (S (S Z))) = Just Base
divisibleby3 (S (S (S x))) = case divisibleby3 x of
  Nothing => Nothing
  Just y => Just (Multiple y)
divisibleby3 _ = Nothing

divisibleby5: (y: Nat) -> Maybe (DivisiblebyX 5 y)
divisibleby5 (S (S (S (S (S Z))))) = Just(Base)
divisibleby5 (S (S (S (S (S x))))) = case divisibleby5 x of
  Nothing => Nothing
  Just y => Just (Multiple y)
divisibleby5 _ = Nothing

fizzbuzz: (x: Nat) -> FizzBuzzProofSimple x
fizzbuzz x = case (divisibleby3 x, divisibleby5 x) of
  (Nothing, Nothing) => Normal x
  (Just fizz_prf, Just buzz_prf) => FizzBuzz fizz_prf buzz_prf
  (Nothing, Just buzz_prf) => Buzz buzz_prf
  (Just fizz_prf, Nothing) => Fizz fizz_prf

wrongfizzbuzz: (x: Nat) -> FizzBuzzProofSimple x
wrongfizzbuzz x = case (divisibleby3 x, divisibleby5 x) of
  (Nothing, Nothing) => Normal x
  (_, Just buzz_prf) => Buzz buzz_prf
  (Just fizz_prf, _) => Fizz fizz_prf


-- exercises in "Type-Driven Development with Idris"
-- chapter 6

import Data.Vect

-- check that all functions are total
%default total

Matrix : (rows : Nat) -> (cols : Nat) -> Type -> Type
Matrix n m t = Vect n (Vect m t)

testMatrix : Matrix 2 3 Double
testMatrix = [[0,0,0],[0,0,0]]

-- for the fun, we rewrite the examples from chapter 3

createEmptyVector : Matrix n 0 t
createEmptyVector {n} = replicate n []

transposeMatrix : Matrix m n t -> Matrix n m t
transposeMatrix [] = createEmptyVector
transposeMatrix (x :: xs) = let xsTrans = transposeMatrix xs in
                                zipWith (::) x xsTrans

addVector : Num t => Vect n t -> Vect n t -> Vect n t
addVector = zipWith (+)

multVector : Num t => Vect n t -> Vect n t -> t
multVector xs ys = sum $ zipWith (*) xs ys

addMatrix : Num t => Matrix m n t -> Matrix m n t -> Matrix m n t
addMatrix = zipWith (addVector)

multMatrixHelper2 : Num t => Vect n t -> Matrix p n t -> Vect p t
multMatrixHelper2 x ys = map (multVector x) ys

multMatrixHelper : Num t => Matrix m n t -> Matrix p n t -> Matrix m p t
multMatrixHelper xs ys = map (flip multMatrixHelper2 $ ys) xs

multMatrix : Num t => Matrix m n t -> Matrix n p t -> Matrix m p t
multMatrix xs ys = multMatrixHelper xs $ transposeMatrix ys

v1 : Matrix 3 2 Nat
v1 = [[1,2],[3,4],[5,6]]

v2 : Matrix 2 4 Nat
v2 = [[7,8,9,10],[11,12,13,14]]

v1v1 : Matrix 3 2 Nat
v1v1 = addMatrix v1 v1
-- v1v1 : Matrix 3 2 Nat
-- [[2, 4], [6, 8], [10, 12]] : Vect 3 (Vect 2 Nat)

v1v2 : Matrix 3 4 Nat
v1v2 = multMatrix v1 v2
-- v1v2 : Matrix 3 4 Nat
-- [[29, 32, 35, 38], [65, 72, 79, 86], [101, 112, 123, 134]] : Vect 3 (Vect 4 Nat)

-- we get nice error messages
--
-- > addMatrix v1 v2
-- (input):1:1-15:When checking an application of function Main.addMatrix:
--         Type mismatch between
--                 Matrix 2 4 Nat (Type of v2)
--         and
--                 Matrix 3 2 Nat (Expected type)
-- > multMatrix v1 v1
-- (input):1:1-16:When checking an application of function Main.multMatrix:
--         Type mismatch between
--                 Matrix 3 2 Nat (Type of v1)
--         and
--                 Matrix 2 p Nat (Expected type)


module sorting_with_proof

import Data.Vect
import Data.Fin
import permutation
import perm_cons
import Finite

%access public export

||| Type of proofs that a vector 'v' of length 'n' is sorted in increasing order.
||| It takes the following parameters : 'n'(length of the vector), 'v'(vector),
||| 'ind'(index). Check if v[ind - 1] <= v[ind]. Note that the predecessor
||| function takes care of the first index ( pred FZ = FZ ).
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)

||| If 'v' is a vector of length 'n' then an element of the Type
||| (IsSorted n v) is a function which given an index 'k' gives
||| a proof that v[k-1] <= v[k]. The special case for first
||| index is taken care of by the predecessor function
||| (pred FZ = FZ).
total
IsSorted : (n : Nat) -> (v : (NatVect n)) -> Type
IsSorted n v = (k : Fin n) -> (SortProof n v k)

||| An element of the type SortedVect n v is of the form (v_sorted, perm, pfPerm, pfSort)
||| where 'v_sorted' is 'v' with its element sorted in increasing order. 'perm' is a
||| permutation such that perm(v) = v_sorted. 'pfPerm' is a proof that perm(v) = v_sorted.
||| 'pfSort' is a proof that 'v_sorted' is sorted.
total
SortedVect : (n : Nat) -> (v : (NatVect n)) -> Type
SortedVect n v = (v_sorted : (NatVect n) **
                 (perm : (PermC n) ** (((applyPerm n Nat perm v) = v_sorted), (IsSorted n v))))


module AssRecRule

import Data.Fin
import Data.Vect

{-
 The recursion function for lists of type `a`. Define this by pattern matching
 recList : (x: Type) -> x -> (Nat -> List Nat -> x -> x) -> (List Nat -> x)
-}
recList : (a: Type) ->  (x: Type) -> x -> (a -> List a -> x -> x) -> (List a -> x)
recList a x base step [] = base
recList a x base step (y :: xs) = step y xs (recList a x base step 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 la = recList a (List b) [] step la where
  step = \y: a => \xs: List a => \listb: List b => (f y) :: listb
{-
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.
-}
foldList : (a: Type) ->  (init: a) -> (op : a -> a -> a) -> List a -> a
foldList a init op la = recList a a init step la where
  step = \y: a => \xs: List a=> \prev : a => (op y prev)

{-
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 Z j = FinZElim j
inducFin xs base step (S p) FZ = base p
inducFin xs base step (S p) (FS k)  = step p k (inducFin xs base step p k)
{-
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 vect =  inducFin xs base step q j vect where
  xs : (n: Nat) -> Fin n -> Type
  xs q j = Vect q a -> a
  base : (m: Nat) -> xs (S m) FZ
  base len = head
  step : (p: Nat) -> (k: Fin p) ->  (prev: xs p k) -> (xs (S p) (FS k))
  step p k prev = prevtail where
    prevtail : Vect (S p) a-> a
    prevtail (hd::tl) = prev tl
{-Q.E.D.-}


module Data.InSet.List

import Data.Bool
import Data.InSet
import Data.List

import Syntax.WithProof

%default total

public export
elems : Equality a => List a -> InSet a
elems []      = []
elems (x::xs) = x :: elems xs

export
elems_of_concat : Equality a => (xs, ys : List a) -> elems (xs ++ ys) == elems xs + elems ys
elems_of_concat [] _ _ = Refl
elems_of_concat (x::xs) ys n = case @@(n =?= x) of
  (True  ** prf) => rewrite prf in Refl
  (False ** prf) => rewrite prf in elems_of_concat xs ys n

-- This is better to be placed in `Data.List`.
reverseOfConc : (x : a) -> (xs : List a) -> reverse (x::xs) = reverse xs ++ [x]
reverseOfConc x []      = Refl
reverseOfConc x (y::ys) = rewrite reverseOfConc y ys in
                          rewrite sym $ appendAssociative (reverse ys) [y] [x] in
                          rewrite revAppend [x, y] ys in
                          Refl

export
reverse_preserves_elems : Equality a => (xs : List a) -> elems (reverse xs) == elems xs
reverse_preserves_elems []      n = Refl
reverse_preserves_elems (x::xs) n = rewrite reverseOfConc x xs in
                                    rewrite elems_of_concat (reverse xs) [x] n in
                                    case @@(n =?= x) of
                                      (True ** prf) => rewrite x_in_same_etc n x [] prf in
                                                       rewrite prf in
                                                       rewrite orTrueTrue $ n `isin` elems (reverse xs) in
                                                       Refl
                                      (False ** prf) => rewrite prf in
                                                        rewrite reverse_preserves_elems xs n in
                                                        rewrite orFalseNeutral $ n `isin` elems xs in
                                                        Refl


module Part2.Sec8_3_deceq
import Data.Vect

{-
data Dec : (prop : Type) -> Type where
     Yes : (prf : prop) -> Dec prop
     No  : (contra : prop -> Void) -> Dec prop

interface DecEq ty where
            decEq : (val1 : ty) -> (val2 : ty) -> Dec (val1 = val2)
-}

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

{- Just for Fun, This code shows code for instance of DecEq -}
data MyPair a b = MkMyPair a b

secondUnequal :  {a1 : a, a2 : a, b1 : b, b2 : b} -> (a1 = a2) -> (contra : (b1 = b2) -> Void) ->  (MkMyPair a1 b1 = MkMyPair a2 b2) -> Void
secondUnequal Refl contra Refl = contra Refl

{- Seems to know that it does not even need to check the second param! -}
firstUnequal : (contra : (a1 = a2) -> Void) -> (MkMyPair a1 b1 = MkMyPair a2 b2) -> Void
firstUnequal contra Refl = contra Refl

(DecEq a, DecEq b) => DecEq (MyPair a b) where
   decEq (MkMyPair a1 b1) (MkMyPair a2 b2) = case decEq a1 a2 of
        Yes Refl => case decEq b1 b2 of
            Yes Refl => Yes Refl
            No contra => No (secondUnequal Refl contra)
        No contra => No (firstUnequal contra)


> module Fin.Operations

> import Data.Fin
> import Data.Vect

> %default total

> %access public export

> ||| 'Tail' of a finite function
> tail : {A : Type} -> {n : Nat} ->
>        (Fin (S n) -> A) -> (Fin n -> A)
> -- tail f k = f (FS k)
> tail f = f . FS

> ||| Maps a finite function to a vector
> toVect : {A : Type} -> {n : Nat} ->
>          (Fin n -> A) -> Vect n A
> toVect {n =   Z} _ = Nil
> toVect {n = S m} f = (f FZ) :: (toVect (tail f))
> -- toVect f = map f range

> ||| Sum of the values of a finite function
> sum : {n : Nat} -> (Fin n -> Nat) -> Nat
> sum {n = Z}   f = Z
> sum {n = S m} f = f FZ + sum (tail f)

> ||| Fold function for Fin
> foldFin : {X : Nat -> Type} -> (f1 : (n : Nat) -> X (S n)) ->
>                                (f2 : (n : Nat) -> X n -> X (S n)) ->
>                                Fin n -> X n
> foldFin {n = Z} f1 f2 x impossible
> foldFin {n = S m} f1 f2 FZ = f1 m
> foldFin {n = S m} f1 f2 (FS i) = f2 m (foldFin f1 f2 i)

Obs: Previous functions are not folds, since they do not take a |Fin|
as argument.


module Rohitkumar.Odds

import Evens

import Intro

{-1-}
public export
data IsOdd : Nat -> Type where
  OneOdd : IsOdd 1
  SSOdd : (n : Nat) -> IsOdd n -> IsOdd (S (S n))
{-2-}
threeIsOdd : IsOdd 3
threeIsOdd = SSOdd (S Z) OneOdd
{-3-}
twonotOdd : IsOdd 2 -> Void
twonotOdd (SSOdd Z OneOdd) impossible
twonotOdd (SSOdd Z (SSOdd _ _)) impossible
{-4-}
nOddThenSnEven : (n : Nat) -> IsOdd n -> IsEven (S n)
nOddThenSnEven (S Z) OneOdd = SSEven Z ZEven
nOddThenSnEven (S (S k)) (SSOdd k x) = SSEven (S k) (nOddThenSnEven k x)
{-5-}
nEvenThenSnOdd : (n : Nat) -> IsEven n -> IsOdd (S n)
nEvenThenSnOdd Z ZEven = OneOdd
nEvenThenSnOdd (S (S k)) (SSEven k x) = SSOdd (S k) (nEvenThenSnOdd k x)
{-6-}
nEitherEvenorOdd : (n : Nat) -> Either (IsEven n) (IsOdd n)
nEitherEvenorOdd Z = Left ZEven
nEitherEvenorOdd (S k) = case (nEitherEvenorOdd k) of
                          (Left l) => Right (nEvenThenSnOdd k l)
                          (Right r) => Left (nOddThenSnEven k r)
{-7-}
nNotEvenandOdd : (n: Nat) -> IsEven n -> IsOdd n -> void
nNotEvenandOdd Z ZEven OneOdd impossible
nNotEvenandOdd Z ZEven (SSOdd _ _) impossible
nNotEvenandOdd (S (S k)) (SSEven k x) (SSOdd k y) = nNotEvenandOdd k x y

{-8-}
nmOddThennmEven : (n : Nat) -> IsOdd n -> (m : Nat) -> IsOdd m -> IsEven (add n m)
nmOddThennmEven (S Z) OneOdd j y = nOddThenSnEven j y
nmOddThennmEven (S (S k)) (SSOdd k x) j y = (SSEven (add k j) (nmOddThennmEven k x j y))
{-9-}
genRefl : (f : (Nat -> Nat)) -> (n : Nat) -> (m : Nat) -> n = m -> f n = f m
genRefl f m m Refl = Refl

halfTheOdd : (n : Nat) -> IsOdd n -> (m : Nat ** ((S (double m)) = n))
halfTheOdd (S Z) OneOdd = (Z ** Refl)
halfTheOdd (S (S k)) (SSOdd k x) = case (halfTheOdd k x) of
                                    (m ** pf) => ((S m) ** (genRefl (\l => S (S l)) (S (double m)) k pf))


||| Properties of factorial functions
module Data.Nat.Fact

import Data.Nat

%default total

||| Recursive definition of factorial.
factRec : Nat -> Nat
factRec Z = 1
factRec (S k) = (S k) * factRec k

||| Tail-recursive accumulator for factItr.
factAcc : Nat -> Nat -> Nat
factAcc Z acc = acc
factAcc (S k) acc = factAcc k $ (S k) * acc

||| Iterative definition of factorial.
factItr : Nat -> Nat
factItr n = factAcc n 1

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

||| Multiplicand-shuffling lemma.
multShuffle : (a, b, c : Nat) -> a * (b * c) = b * (a * c)
multShuffle a b c =
  rewrite multAssociative a b c in
    rewrite multCommutative a b in
      sym $ multAssociative b a c

||| Multiplication of the accumulator.
factAccMult : (a, b, c : Nat) ->
  a * factAcc b c = factAcc b (a * c)
factAccMult _ Z _ = Refl
factAccMult a (S k) c =
  rewrite factAccMult a k (S k * c) in
    rewrite multShuffle a (S k) c in
      Refl

||| Addition of accumulators.
factAccPlus : (a, b, c : Nat) ->
  factAcc a b + factAcc a c = factAcc a (b + c)
factAccPlus Z _ _ = Refl
factAccPlus (S k) b c =
  rewrite factAccPlus k (S k * b) (S k * c) in
    rewrite sym $ multDistributesOverPlusRight (S k) b c in
      Refl

||| The recursive and iterative definitions are the equivalent.
factRecItr : (n : Nat) -> factRec n = factItr n
factRecItr Z = Refl
factRecItr (S k) =
  rewrite factRecItr k in
    rewrite factAccMult k k 1 in
      rewrite multOneRightNeutral k in
        factAccPlus k 1 k


module Abishekrajan.Odds

import Evens

import Intro

data IsOdd : Nat -> Type where
  OneOdd : IsOdd 1
  SSOdd : (n : Nat) -> IsOdd n -> IsOdd (S (S n))

threeOdd : IsOdd 3
threeOdd = SSOdd 1 OneOdd

twoNotOdd : IsOdd 2 -> Void
twoNotOdd (SSOdd Z OneOdd) impossible
twoNotOdd (SSOdd Z (SSOdd x y)) impossible

nOddSnEven : (n: Nat) -> IsOdd n -> IsEven (S n)
nOddSnEven (S Z) OneOdd = (SSEven Z ZEven)
nOddSnEven (S (S k)) (SSOdd k x) = SSEven (S k) (nOddSnEven k x)

nEvenSnOdd : (n: Nat) -> IsEven n -> IsOdd (S n)
nEvenSnOdd Z ZEven = OneOdd
nEvenSnOdd (S (S k)) (SSEven k x) = SSOdd (S k) (nEvenSnOdd k x)

nEvenOrOdd : (n: Nat) -> Either (IsEven n) (IsOdd n)
nEvenOrOdd Z = Left ZEven
nEvenOrOdd (S k) = case (nEvenOrOdd k) of
                       (Left l) => Right (nEvenSnOdd k l)
                       (Right r) => Left (nOddSnEven k r)

nNotEvenAndOdd : (n: Nat) -> (IsEven n) -> (IsOdd n) -> Void
nNotEvenAndOdd Z ZEven OneOdd impossible
nNotEvenAndOdd Z ZEven (SSOdd p q) impossible
nNotEvenAndOdd (S (S k)) (SSEven k x) (SSOdd k y) = nNotEvenAndOdd k x y

mOddnOddmplusnEven : (m: Nat) -> IsOdd m -> (n: Nat) -> IsOdd n -> IsEven (add m n)
mOddnOddmplusnEven (S Z) OneOdd (S Z) OneOdd = SSEven 0 ZEven
mOddnOddmplusnEven (S Z) OneOdd (S (S k)) (SSOdd k x) = SSEven (S k) (mOddnOddmplusnEven (S Z) OneOdd k x)
mOddnOddmplusnEven (S (S k)) (SSOdd k x) n y = SSEven (add k n) (mOddnOddmplusnEven k x n y)

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

oddIsSDouble : (n: Nat) -> IsOdd n -> (k: Nat ** (S (double k)) = n)
oddIsSDouble (S Z) OneOdd = (0 ** Refl)
oddIsSDouble (S (S k)) (SSOdd k x) = case (oddIsSDouble k x) of
            (m ** y) => ((S m) ** apNat (\l => S (S l)) (S (double m)) k y)


module Bezout

import Data.Vect
import Data.Fin

{-Copied from Chinmaya's code. Gives quotient and remainder on divison-}
{-This just computes the qoutient and the remainder, but it doesn't prove that they indeed satisfy the conditions a = b*q + r and r < b -}
Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat)
Eucl Z b = (Z,Z)
Eucl (S k) b = case (lte (S (S k)) b) of
                    False => (S(fst(Eucl (minus (S k) b) b)), snd(Eucl (minus (S k) b) b))
                    True => (Z, S k)
{-Just a slight modification of the Euclid's division function to give the remainder -}
rem : (a : Nat) -> (b : Nat) -> Nat
rem Z b = Z
rem (S k) b = case (lte (S (S k)) b) of
                    False => (rem (minus (S k) b) b)
                    True => (S k)
{-Let rk be the remainder in the Euclidean algorithm at the k-2th step.
Let rk = ak*r0 + bk*r1 where r0 and r1 are the original inputs.Correspondingly  rsk = ask*r0 + bsk*r1 where sk = k+1
Then the I am going to the next step in the Euclid algorithm and changing the coefficients.
These formulas can be easily derived.-}
Euclnos: (Int,Int,Int,Int,Int,Int)->(Int,Int,Int,Int,Int,Int)
Euclnos (rk, rsk ,ak ,ask, bk ,bsk) = (rsk,rssk,ask,assk,bsk,bssk) where
  rssk = cast(snd (Eucl (cast rk) (cast rsk)))
  bssk =bk-bsk* (cast(fst (Eucl (cast rk) (cast rsk))))
  assk =ak-ask* (cast(fst (Eucl (cast rk) (cast rsk))))
{-Does the Euclnos repeatedy until the remainder is zero. Then the previous remainder is the GCD.-}
Bezouttuple: (Int,Int,Int,Int,Int,Int)->(Int,Int,Int,Int,Int,Int)
Bezouttuple (rk, rsk ,ak ,ask, bk, bsk) = case rsk of
                                        0 => (rk, rsk, ak, ask, bk, bsk)
                                        _ => (Bezouttuple (Euclnos (rk ,rsk, ak ,ask ,bk ,bsk)))
{-Returns 2 particular integers out of a 6 tuple-}
returnab: (Int,Int,Int,Int,Int,Int)->(Int,Int)
returnab (a ,b ,c ,d, e ,f)  = (c,e)
{-Returns the Bezout coefficients-}
Bezout : Nat ->Nat ->(Int, Int)
Bezout k j =  (returnab(Bezouttuple((cast k) , (cast j),1, 0 ,0 ,1)))

{-}
just the functions to compute the GCD in two different ways.
{-}

gcd2 : Nat -> Nat -> Nat
gcd2 a b = (cast (((cast a)*(snd (Bezout a b))) + ((cast b)*(fst (Bezout a b)))))

gcdab : Nat -> Nat -> Nat
gcdab b Z = b
gcdab a b = gcdab b (snd (Eucl a b))

{-}
given below are the auxilary functions to the proof that given a and b, there exist q and r such that a = b*q + r.
The algorithm above just computes these two numbers, but it doesn't prove that (a = b*q + r and r < b)

f1 is the proof that a + 1 = b*q + (r + 1) given that a = b*q + r

aux1f2 is the proof that given a + 1 <= b, a <= b
aux2f2 is the proof that given a and b, either a <= b or a >= b + 1

aux1f3 is the proof that given a <= b and b <= a, a = b
aux2f3 proves that a = b + c and c = d together imply a = b + d
aux3f3 is the proof that given a = b*c + b, a = b*(c + 1) + 0

All these proofs (except maybe aux2f3) were necessary to avoid various type mismatch errors.
{-}

apNat2 : (a : Nat) -> (b : Nat) -> (a = b) -> (S a = S b)
apNat2 a a Refl = Refl

aux1f2 : (a : Nat) -> (b : Nat) -> (LTE (S a) b) -> (LTE a b)
aux1f2 Z Z LTEZero impossible
aux1f2 Z Z (LTESucc _) impossible
aux1f2 Z (S k) x = LTEZero
aux1f2 (S a) (S k) (LTESucc x) = (LTESucc (aux1f2 a k x))

aux2f2 : (a : Nat) -> (b : Nat) -> (Either (LTE a b) (LTE (S b) a))
aux2f2 Z Z  = Left LTEZero
aux2f2 Z (S b) = Left LTEZero
aux2f2 (S k) Z = Right (LTESucc LTEZero)
aux2f2 (S k) (S b) = step where
                  step = case (aux2f2 k b) of
                    (Left l) => (Left (LTESucc l))
                    (Right r) => (Right (LTESucc r))

f1 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (a = b + c) -> ((S a) = b + (S c))
f1 a c k pf = (trans (apNat2 a (c + k) pf) (plusSuccRightSucc c k))

aux1f3 : (a : Nat) -> (b : Nat) -> (LTE a b) -> (LTE b a) -> (a = b)
aux1f3 Z Z LTEZero LTEZero = Refl
aux1f3 Z (S _) LTEZero LTEZero impossible
aux1f3 Z (S _) LTEZero (LTESucc _) impossible
aux1f3 (S _) Z LTEZero LTEZero impossible
aux1f3 (S _) Z (LTESucc _) LTEZero impossible
aux1f3 (S k) (S j) (LTESucc x) (LTESucc y) = (apNat2 k j (aux1f3 k j x y))

aux2f3 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (d : Nat) -> (a = b + c) -> (c = d) -> (a = b + d)
aux2f3 a b Z Z prf Refl = prf
aux2f3 _ _ Z (S _) _ Refl impossible
aux2f3 _ _ (S _) Z _ Refl impossible
aux2f3 (b + (S j)) b (S j) (S j) Refl Refl = Refl

aux3f3 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (a = (b*c) + b) -> (a = b*(S c) + Z)
aux3f3 a b k prf = (trans (trans (trans (prf) (plusCommutative (b*k) b)) (sym (multRightSuccPlus b k))) (sym (plusZeroRightNeutral (b*(S k)))))

{-Caveat : the function elemproof hasn't been programmed for the divisor b being equal to zero -}
{-replacig b with (S b) everywhere in the proof has been done to avoid the case b = 0-}

elemproof1 : (a : Nat) -> (b : Nat) -> (x : (Nat, Nat) ** ((a = (b*(fst x)) + (snd x)) , (LTE (S (snd x)) b)))
elemproof1 Z (S b) = ((0,0) ** ((sym (trans (trans (plusCommutative ((S b)*Z) Z) (sym (multLeftSuccPlus (S b) Z))) (multZeroRightZero (S (S b))))), (LTESucc LTEZero)))
elemproof1 (S k) (S b) = step where
                     step = case (elemproof1 k (S b)) of
                       ((q,r) ** (pf , pff)) => case (aux2f2 (S (S r)) (S b)) of
                                                  Left l => ((q , (S r)) ** ((f1 k ((S b)*q) r pf) , l))
                                                  Right (LTESucc ri) => (((S q) , Z) ** ((aux3f3 (S k) (S b) q (aux2f3 (S k) ((S b)*q) (S r) (S b) (f1 k ((S b)*q) r pf) (aux1f3 (S r) (S b) pff ri))) , (LTESucc LTEZero)))

{-proof of existence of remainders and quotients is necessary to define the concept of divisibilty -}
{-The next step ahead might be to proof the uniqueness of these remainders and quotients probably -}

-- defining divisibilty as b | a if there exists q such that a = b*q + Z
-- if b | a and c | b, then c | a.
-- if c | a and c | b, then c | (a + b)

-- auxplusDiv 1 to 4 are just auxilary proofs.
auxtransDiv : (a : Nat) -> (b : Nat) -> (c : Nat) -> (d : Nat) -> (b = c*q)
auxtransDiv a b c d = ?auxtransDiv_rhs

auxplusDiv1 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (d : Nat) -> (a = b) -> (c = d) -> (a + c = b + d)
auxplusDiv1 b b d d Refl Refl = Refl

auxplusDiv2 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (q : Nat) -> (p : Nat) -> (a = c*q) -> (b = c*p) -> (a + b = c*(q + p))
auxplusDiv2 a b c q p pf1 pf2 = (trans (auxplusDiv1 a (c*q) b (c*p) pf1 pf2) (sym(multDistributesOverPlusRight c q p)))

auxplusDiv3 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (d : Nat) -> (a = c) -> (b = d) -> ((minus a b) = (minus c d))
auxplusDiv3 c d c d Refl Refl = Refl

-- Holes !!
auxplusDiv4 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (q : Nat) -> (p : Nat) -> (a + b = c*q) -> (b = c*p) -> (a = c*(minus q p))
auxplusDiv4 a b c q p pf1 pf2 = ?auxplusDiv3_rhs

--These statements are the two main facts we might be interested in.
plusDiv1 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (q : Nat ** a = c*q) -> (p : Nat ** b = c*p) -> (f : Nat ** a + b = c*f)
plusDiv1 a b c (q ** pf1) (p ** pf2) = ((q + p) ** (auxplusDiv2 a b c q p pf1 pf2))

plusDiv2 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (q : Nat ** a + b = c*q) -> (p : Nat ** b = c*p) -> (f : Nat ** a = c*f)
plusDiv2 a b c (q ** pf1) (p ** pf2) = ((minus q p) ** (auxplusDiv4 a b c q p pf1 pf2))

-- I'll try and prove some (possibly useful) facts about the gcd.
-- weak definition of the gcd : d | a, d | b and if c | a and c | b, then c <= d.
--This is the common Factor Type

isCommonFactor : Nat -> Nat -> Nat -> Type
isCommonFactor a b c = ((q : Nat ** a = c*q),(p : Nat ** b = c*p))

--This is the GCD type
-- d is "a" gcd of a and b if isGCD a b d type is inhabited.
-- Uniqueness of GCD not assumed !!
-- the gcd is just assumed to be bigger than any other common divisor, not a multiple of it.

isGCD : Nat -> Nat -> Nat -> Type
isGCD a b d = ((isCommonFactor a b d) , ((c : Nat) -> (isCommonFactor a b c) -> (LTE c d)))

-- try to prove that if d is "a" gcd of (a,b) then it is "a" gcd of (a+b,a)

gcdfact1 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD a b d) -> (isCommonFactor (a + b) b d)
gcdfact1 a b d (((q ** pf1),(p ** pf2)),f) = ((plusDiv1 a b d (q ** pf1) (p ** pf2)),(p ** pf2))

gcdfact2 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD a b d) -> (c : Nat) -> (isCommonFactor (a + b) b c) -> (LTE c d)
gcdfact2 a b d (pf , f) c ((q ** pf1),(p ** pf2)) = (f c ((plusDiv2 a b c (q ** pf1) (p ** pf2)),(p ** pf2)))

maingcdfact1 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD a b d) -> (isGCD (a + b) b d)
maingcdfact1 a b d pf = ((gcdfact1 a b d pf),(gcdfact2 a b d pf))

-- now the proof that if d is "a" gcd of (a+b,b), then it is "a" gcd of (a,b)

gcdfact3 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD (a + b) b d) -> (isCommonFactor a b d)
gcdfact3 a b d (((q ** pf1),(p ** pf2)),f) = ((plusDiv2 a b d (q ** pf1) (p ** pf2)),(p ** pf2))

gcdfact4 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD (a + b) b d) -> (c : Nat) -> (isCommonFactor a b c) -> (LTE c d)
gcdfact4 a b d (pf, f) c ((q ** pf1),(p ** pf2)) = (f c ((plusDiv1 a b c (q ** pf1) (p ** pf2)),(p ** pf2)))

maingcdFact2 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD (a + b) b d) -> (isGCD a b d)
maingcdFact2 a b d pf = ((gcdfact3 a b d pf),(gcdfact4 a b d pf))

-- now the proof that if d is "a" gcd of (a,b), it is also "a" gcd of (b,a)

symCommonFactor : (a : Nat) -> (b : Nat) -> (c : Nat) -> (isCommonFactor a b c) -> (isCommonFactor b a c)
symCommonFactor a b c ((p ** pf1),(q ** pf2)) = ((q ** pf2),(p ** pf1))

symGCD1 : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD a b d) -> ((c : Nat) -> (isCommonFactor b a c) -> (LTE c d))
symGCD1 a b d (pf, f) = g where
                          g c ((p ** pf1),(q ** pf2)) = f c ((q ** pf2),(p ** pf1))

symGCD : (a : Nat) -> (b : Nat) -> (d : Nat) -> (isGCD a b d) -> (isGCD b a d)
symGCD a b d (pf , f) = ((symCommonFactor a b d pf) , (symGCD1 a b d (pf , f)))

-- I'll list the types and functions that might be useful
-- The GCD type : isGCD : Nat -> Nat -> Nat -> Type
--                isGCD a b d = ((isCommonFactor a b d) , ((c : Nat) -> (isCommonFactor a b c) -> (LTE c d)))
-- maingcdfact1 , maingcdfact2 , symGCD.

-- The next step might be to show that the natural number that the euclidian algorithm gives us is indeed a gcd
-- also uniqueness of gcd.