module Data.Nat.Equational

import Data.Nat

%default total

||| Subtract a number from both sides of an equation.
||| Due to partial nature of subtraction in natural numbers, an equation of
||| special form is required in order for subtraction to be total.
export
subtractEqLeft : (a : Nat) -> {b, c : Nat} -> a + b = a + c -> b = c
subtractEqLeft 0 prf = prf
subtractEqLeft (S k) prf = subtractEqLeft k $ succInjective (k + b) (k + c) prf

||| Subtract a number from both sides of an equation.
||| Due to partial nature of subtraction in natural numbers, an equation of
||| special form is required in order for subtraction to be total.
export
subtractEqRight : {a, b : Nat} -> (c : Nat) -> a + c = b + c -> a = b
subtractEqRight c prf =
    subtractEqLeft c $
    rewrite plusCommutative c a in
    rewrite plusCommutative c b in
    prf

||| Add a number to both sides of an inequality
export
plusLteLeft : (a : Nat) -> {b, c : Nat} -> LTE b c -> LTE (a + b) (a + c)
plusLteLeft 0 bLTEc = bLTEc
plusLteLeft (S k) bLTEc = LTESucc $ plusLteLeft k bLTEc

||| Add a number to both sides of an inequality
export
plusLteRight : {a, b : Nat} -> (c : Nat) -> LTE a b -> LTE (a + c) (b + c)
plusLteRight c aLTEb =
    rewrite plusCommutative a c in
    rewrite plusCommutative b c in
    plusLteLeft c aLTEb

||| Subtract a number from both sides of an inequality.
||| Due to partial nature of subtraction, we require an inequality of special form.
export
subtractLteLeft : (a : Nat) -> {b, c : Nat} -> LTE (a + b) (a + c) -> LTE b c
subtractLteLeft 0 abLTEac = abLTEac
subtractLteLeft (S k) abLTEac = subtractLteLeft k $ fromLteSucc abLTEac

||| Subtract a number from both sides of an inequality.
||| Due to partial nature of subtraction, we require an inequality of special form.
export
subtractLteRight : {a, b : Nat} -> (c : Nat) -> LTE (a + c) (b + c) -> LTE a b
subtractLteRight c acLTEbc =
    subtractLteLeft c $
    rewrite plusCommutative c a in
    rewrite plusCommutative c b in
    acLTEbc

||| If one of the factors of a product is greater than 0, then the other factor
||| is less than or equal to the product..
export
rightFactorLteProduct : (a, b : Nat) -> LTE b (S a * b)
rightFactorLteProduct a b = lteAddRight b

||| If one of the factors of a product is greater than 0, then the other factor
||| is less than or equal to the product..
export
leftFactorLteProduct : (a, b : Nat) -> LTE a (a * S b)
leftFactorLteProduct a b =
    rewrite multRightSuccPlus a b in
    lteAddRight a


module Semiring

import Data.Morphisms

%default total
%hide (+)
%hide (*)
%access public export

interface Semiring a where
  (+) : a -> a -> a
  (*) : a -> a -> a
  one : a
  zer : a

sum : (Foldable f, Semiring a) => f a -> a
sum = foldl (+) zer

mul : (Foldable f, Semiring a) => f a -> a
mul = foldl (*) one

Semiring Bool where
  x + y = x || y
  x * y = x && y
  one = True
  zer = False

Semiring b => Semiring (Morphism a b) where
  (Mor f) + (Mor g) = Mor (\x => f x + g x)
  (Mor f) * (Mor g) = Mor (\x => f x * g x)
  one = Mor (\_ => one)
  zer = Mor (\_ => zer)

Semiring Double where
  (+) = prim__addFloat
  (*) = prim__mulFloat
  one = 1
  zer = 0

Semiring Int where
  (+) = prim__addInt
  (*) = prim__mulInt
  one = 1
  zer = 0

interface Semiring a => VerifiedSemiring a where
  plusAssoc : (x, y, z : a) -> (x + y) + z = x + (y + z)
  multAssoc : (x, y, z : a) -> (x * y) * z = x * (y * z)
  plusComm  : (x : a) -> (y : a) -> x + y = y + x
  plusId : (x : a) -> x + Semiring.zer = x
  mulIdR : (x : a) -> x * Semiring.one = x
  mulIdL : (x : a) -> Semiring.one * x = x
  mulAnR : (x : a) -> x * Semiring.zer = Semiring.zer
  mulAnL : (x : a) -> Semiring.zer * x = Semiring.zer
  mulDsR : (x, y, z : a) -> (x + y) * z = (x * z) + (y * z)
  mulDsL : (x, y, z : a) -> x * (y + z) = (x * y) + (x * z)

VerifiedSemiring Bool where
  plusAssoc False y z = Refl
  plusAssoc True  y z = Refl
  multAssoc False y z = Refl
  multAssoc True  y z = Refl
  plusComm False False = Refl
  plusComm False True  = Refl
  plusComm True  False = Refl
  plusComm True  True  = Refl
  plusId False = Refl
  plusId True  = Refl
  mulIdL False = Refl
  mulIdL True  = Refl
  mulIdR False = Refl
  mulIdR True  = Refl
  mulAnR False = Refl
  mulAnR True  = Refl
  mulAnL x = Refl
  mulDsR False y z = Refl
  mulDsR True False False = Refl
  mulDsR True False True  = Refl
  mulDsR True True False  = Refl
  mulDsR True True True   = Refl
  mulDsL False y z = Refl
  mulDsL True  y z = Refl

Semiring Nat where
  (+) = plus
  (*) = mult
  one = 1
  zer = 0

VerifiedSemiring Nat where
  plusAssoc x y z = sym (plusAssociative x y z)
  multAssoc x y z = sym (multAssociative x y z)
  plusComm = plusCommutative
  plusId = plusZeroRightNeutral
  mulAnL = multZeroLeftZero
  mulAnR = multZeroRightZero
  mulIdL = multOneLeftNeutral
  mulIdR = multOneRightNeutral
  mulDsL = multDistributesOverPlusRight
  mulDsR = multDistributesOverPlusLeft

interface Semigroup a => VerifiedSemigroup a where
  semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r

interface (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where
  monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l
  monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r

interface VerifiedMonoid a => CommutativeMonoid a where
  mappendCommutes : (x, y : a) -> x <+> y = y <+> x

CommutativeMonoid a => Semiring (Endomorphism a) where
  (Endo f) + (Endo g) = Endo (\x => f x <+> g x)
  (Endo f) * (Endo g) = Endo (f . g)
  zer = Endo (const neutral)
  one = Endo id


module Void

%default total

{-
  data Void : Type where

-}

twoPlusTwoNotFive : 2 + 2 = 5 -> Void
twoPlusTwoNotFive Refl impossible

valueNotSucc : (x : Nat) -> x = S x -> Void
valueNotSucc _ Refl impossible

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

-- more precise implementation of checkEqNat

zeroNotSucc : Z = S k -> Void
zeroNotSucc Refl impossible

succNotZero : S k = Z -> Void
succNotZero Refl impossible

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

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


{-
Code examples about

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

and

isElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)
-}

module Part2.Sec9_1_elem
import Data.Vect

%default total
%access public export

{- This type of code derives automatically with term search !-}
twoTest : Elem 2 [1,2,3]
twoTest = There Here

{-
second condition derived via interactive development resulted in absurd and I just
commented it out, the function is still total, uncommented compiles too

Note:
absurd : Uninhabited t => t -> a
later is uninhabited
-}
removeElem : (value : a) -> (xs : Vect (S n) a) ->
                   (prf : Elem value xs) ->
                   Vect n a
removeElem value (value :: ys) Here = ys
-- removeElem {n = Z} value (y :: []) (There later) = absurd later
removeElem {n = (S k)} value (y :: ys) (There later) = y :: removeElem value ys later

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

{-
repl:
*Part2/Sec9_1_elem> removeElem 2 [1,2,3,4,5] (There Here)
[1, 3, 4, 5] : Vect 4 Integer

*Part2/Sec9_1_elem> removeElem_auto 2 [1,2,3,4,5]
[1, 3, 4, 5] : Vect 4 Integer
-}

data Test : (Vect 1 String) -> Type where
   MkTest : Test (removeElem_auto "str" ["hello", "str"])

data Test1 : (Vect 1 String) -> Type where
   MkTest1 : Test1 (removeElem "str" ["hello", "str"] (There Here))

{-
Note: removeElem seems to be not resolved/reduced at compile time, same it true for Haskell
repl:
*Part2/Sec9_1_elem> :t MkTest
MkTest : Test (removeElem_auto "str" ["hello", "str"])

*Part2/Sec9_1_elem> :t MkTest1
MkTest1 : Test1 (removeElem "str" ["hello", "str"] (There Here))
-}

{-
However: this does not compile :) but it does in Haskell :(
data TestWrong : (Vect 1 String) -> Type where
   MkTestWrong : TestWrong (removeElem "str1" ["hello", "str"] (There Here))

Compiler error:
   |
57 |    MkTestWrong : TestWrong (removeElem "str1" ["hello", "str"] (There Here))
   |                                                                 ~~~~~~~~~~
When checking type of Part2.Sec9_1_elem.MkTestWrong:
When checking argument later to constructor Data.Vect.There:
        Type mismatch between
                Elem x (x :: xs) (Type of Here)
        and
                Elem "str1" ["str"] (Expected type)

        Specifically:
                Type mismatch between
                        "str1"
                and
                        "str"
-}

{-
 Type safe version of elem function
 elem : Eq ty => (value : ty) -> (xs : Vect n ty) -> Bool
 -}
notInNil : Elem value [] -> Void
notInNil Here impossible
notInNil (There _) impossible

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

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

{-
*Part2/Sec9_1_elem> isElem 1 [2,3,1]
Yes (There (There Here)) : Dec (Elem 1 [2, 3, 1])
-}


module TheoremProving

%default total

-- equality
{-
  data Equal : a -> b -> Type where
    Refl : Equal x x

  Equal x y is also written as x = y
-}

fiveIsFive : Equal 5 5
fiveIsFive = Refl

twoPlusTwoIsFour : 2 + 2 = 4
twoPlusTwoIsFour = Refl

-- the Empty type - Void, useful for
-- proving impossible cases in theorem proving.
-- Essentially, proof by contradiction

-- proof that zero can never be equal to a successor
disjoint : (n : Nat) -> Z = S n -> Void
disjoint n prf = replace { p = disjointTy } prf () where
  disjointTy : Nat -> Type
  disjointTy Z = ()
  disjointTy (S k) = Void

-- proving theorems
-- a proof in Idris is basically a program with a precise enough type to guarantee a special property of interest
-- Hence we write proofs the same way as other programs.

plusReduces : (n : Nat) -> plus Z n = n
plusReduces n = Refl

plusReducesZ : (n : Nat) -> n = plus n Z
plusReducesZ Z = Refl
plusReducesZ (S k) = cong S (plusReducesZ k)

plusReducesS : (n : Nat) -> (m : Nat) -> S (plus n m) = plus n (S m)
plusReducesS Z m = Refl
plusReducesS (S k) m = cong S (plusReducesS k m)


module Main

import Data.Primitives.Views

everyOther : Stream ty -> Stream ty
everyOther (e1 :: e2 :: es) = e2 :: everyOther es

data InfList : Type -> Type where
  (::) : (value : elem) -> Inf (InfList elem) -> InfList elem

Functor InfList where
  map f (x :: xs) = f x :: map f xs

total
countFrom : Integer -> InfList Integer
countFrom x = x :: countFrom (x + 1)

total
getPrefix : (count : Nat) -> InfList ty -> List ty
getPrefix Z xs = []
getPrefix (S k) (value :: xs) = value :: getPrefix k xs

data Face : Type where
  Heads : Face
  Tails : Face

Show Face where
  show Heads = "Heads"
  show Tails = "Tails"

getFace : Int -> Face
getFace n with (divides n 2)
  getFace ((2 * div) + rem) | (DivBy prf) =
    case rem of
      0 => Heads
      _ => Tails

randoms : Int -> Stream Int
randoms seed =
  let seed' = 1664525 * seed + 1013904223
  in (seed' `shiftR` 2) :: randoms seed'

coinFlips : (count : Nat) -> Stream Int -> List Face
coinFlips count xs = map getFace (take count xs)

squareRootApprox : (number : Double) -> (approx : Double) -> Stream Double
squareRootApprox number approx = approx :: squareRootApprox number next
  where
    next = (approx + (number / approx)) / 2

squareRootBound : (max : Nat) -> (number : Double) -> (bound : Double) -> (approxs : Stream Double) -> Double
squareRootBound Z number bound (val :: xs) = val
squareRootBound (S k) number bound (val :: xs) =
  case (val * val - number <= bound) of
    True  => val
    False => squareRootBound k number bound xs

squareRoot : (numner : Double) -> Double
squareRoot number = squareRootBound 100 number 0.00000000001 (squareRootApprox number number)

main : IO ()
main = do
  printLn $ take 10 (everyOther [1..]) -- [2,4,6,8,10,12,14,16,18,20]
  printLn $ getPrefix 10 (map (*2) (countFrom 1)) -- [2,4 .. 20]
  printLn $ coinFlips 6 (randoms 12345) -- [T,H,T,T,H,T]
  printLn $ take 3 (squareRootApprox 10 10)
  printLn $ take 3 (squareRootApprox 100 25)
  printLn $ squareRoot 6
  printLn $ squareRoot 2500
  printLn $ squareRoot 2501


module Evens

-- The type `IsEven(n)`  has terms (objects) that are proofs that `n` is even.
data IsEven : Nat -> Type where
  ZeroEven : IsEven 0
  SSEven : (n: Nat) -> (pf: IsEven n) -> IsEven (S (S n))

twoEven : IsEven 2
twoEven = SSEven Z ZeroEven

fourEven : IsEven 4
fourEven = SSEven _ twoEven

half : (n: Nat) -> IsEven n -> Nat
half Z ZeroEven = 0
half (S (S k)) (SSEven k pf) =
  S (half k pf)

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

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

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

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

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

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

nAndSnNotBothEven : (n: Nat) -> IsEven n -> IsEven (S n) -> Void
nAndSnNotBothEven Z ZeroEven ZeroEven impossible
nAndSnNotBothEven Z ZeroEven (SSEven _ _) impossible
nAndSnNotBothEven (S (S k)) (SSEven k pf) (SSEven (S k) x) =
  nAndSnNotBothEven k pf x

nOddThenSnEven : (n: Nat) -> (IsEven n -> Void) -> IsEven (S n)
nOddThenSnEven n contra =
  (case (nOrSnEven n) of
        (Left l) => void (contra l)
        (Right r) => r
        )

halfSucc : (n : Nat) -> ((IsEven n) -> Void) -> Nat
halfSucc n contra = half (S n) (nOddThenSnEven n contra)

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

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

isDouble: Nat -> Type
isDouble n = (m : Nat ** (double m) = n)

evenIsDouble: (n: Nat) -> IsEven n -> (isDouble n)
evenIsDouble = byTwo

transport : (a : Type) -> (P : a -> Type) ->  (x : a) -> (y : a) -> (x = y) -> P(x) -> P(y)
transport a P y y Refl z = z

doubleIsEven: (n: Nat) -> isDouble n -> IsEven n
doubleIsEven n pair =
  case pair of
        (k ** pf) =>
          transport Nat IsEven (double k) n pf (doubleEven k)

-- The Peano axioms

sInj : (x: Nat) -> (y: Nat) -> (S x = S y) -> (x = y)
sInj Z Z Refl = Refl
sInj (S k) (S k) Refl = Refl

sNotZ : (x: Nat) -> (S x = Z) -> Void
sNotZ _ Refl impossible

symmEq : (x: Nat) -> (y: Nat) -> (x = y) -> (y = x)
symmEq y y Refl = Refl

transEq: (x: Nat) -> (y: Nat) -> (z: Nat) -> (x = y) -> (y = z) -> (x = z)
transEq y y y Refl Refl = Refl

--- Less than or equal and subtraction

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

superSub : (n: Nat) -> (m : Nat) -> (LTE m n) -> (diff: Nat ** LTE diff n)
superSub n Z LTEZero = (n ** lteRefl)
superSub (S n) (S m) (LTESucc x) = case (superSub n m x) of
                                               (diff ** pf) => (diff ** lteSuccRight pf)

oneLTEFour : LTE 1 4
oneLTEFour = LTESucc LTEZero

fourMinusOne : Nat
fourMinusOne = sub 4 1 oneLTEFour

-- Range type

data InRange : Nat -> Nat -> Type where
  MkInRange : (l : Nat) -> (u : Nat) -> (n : Nat) -> LTE l n -> LTE n u -> InRange l u

oneBetween0And4 : InRange 0 4
oneBetween0And4 = MkInRange 0 4 1 LTEZero oneLTEFour

Cast (InRange n m) Nat where -- cast is an interface (typeclass in scala)
  cast (MkInRange n m k x y) = k

one: Nat
one = cast oneBetween0And4

--- space


import Data.Vect

tryIndex : Integer -> Vect n a -> Maybe a
tryIndex {n} i xs = case integerToFin i n of
                         Nothing => Nothing
                         (Just idx) => Just (index idx xs)

vectTake : (n : Nat) -> Vect (n + m) a -> Vect n a
vectTake Z xs = []
vectTake (S k) (x :: xs) = x :: vectTake k xs

sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries pos [] [] = Nothing
sumEntries 0 (x :: xs) (y :: ys) = Just (x + y)
sumEntries pos (x :: xs) (y :: ys) = sumEntries (pos - 1) xs ys

altSumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
altSumEntries {n} pos xs ys = case integerToFin pos n of
                                   Nothing => Nothing
                                   (Just x) => Just (index x xs + index x ys)


module Data.Binary

import Data.Nat.Properties
import Data.Binary.Digit
import Syntax.PreorderReasoning

%default total

||| Bin represents binary numbers right-to-left.
||| For instance `4` can be represented as `OOI`.
||| Note that representations are not unique: one may append arbitrarily
||| many Os to the right of the representation without changing the meaning.
public export
Bin : Type
Bin = List Digit

||| Conversion from lists of bits to natural number.
public export
toNat : Bin -> Nat
toNat = foldr (\ b, acc => toNat b + 2 * acc) 0

||| Successor function on binary numbers.
||| Amortised constant time.
public export
suc : Bin -> Bin
suc [] = [I]
suc (O :: bs) = I :: bs
suc (I :: bs) = O :: (suc bs)

||| Correctness proof of `suc` with respect to the semantics in terms of Nat
export
sucCorrect : {bs : Bin} -> toNat (suc bs) === S (toNat bs)
sucCorrect {bs = []} = Refl
sucCorrect {bs = O :: bs} = Refl
sucCorrect {bs = I :: bs} = Calc $
  |~ toNat (suc (I :: bs))
  ~~ toNat (O :: suc bs) ...( Refl )
  ~~ 2 * toNat (suc bs)  ...( Refl )
  ~~ 2 * S (toNat bs)    ...( cong (2 *) sucCorrect )
  ~~ 2 + 2 * toNat bs    ...( unfoldDoubleS )
  ~~ S (toNat (I :: bs)) ...( Refl )


module Monoid

%access public export

||| The proof that some element is identity in the type
total
IsIdentity : (mon : Type) -> ((*) : mon -> mon -> mon) -> (e : mon) -> Type
IsIdentity mon (*) e = (a : mon) -> ((a*e) = a, (e*a) = a)

||| Given a type and a binary operation the type of proofs that the operation is associative
total
Associative : (typ : Type) -> ((*): typ -> typ -> typ) -> Type
Associative typ (*) = (a : typ) -> (b : typ) -> (c : typ) -> ((a * b) * c) = (a * (b * c))

||| Given a type and a binary operation the type of proofs that the operation is commutative
total
Commutative : (typ : Type) -> ((*) : typ -> typ -> typ) -> Type
Commutative typ (*) = (a : typ) -> (b : typ) -> (a * b) = (b * a)

||| Given a type and a binary operation the type of proofs that identity exists
total
IdentityExists : (typ : Type) -> ((*) : typ -> typ -> typ) -> Type
IdentityExists typ (*) = (e : typ ** (IsIdentity typ (*) e))
--((a : typ) -> ((a*e) = a, (e*a) = a)))

total
IsMonoid : (mon : Type) -> ((*) : mon -> mon -> mon) -> Type
IsMonoid mon (*) = (Associative mon (*), IdentityExists mon (*))

||| Gives the identity of the monoid
total
Monoid_id : (mon : Type) -> ((*) : mon -> mon -> mon) -> (IsMonoid mon (*))
            -> (IdentityExists mon (*))
Monoid_id mon (*) (pfAss, pfId) = pfId


module Rationals

data NotZero : Integer -> Type where --Proof that a number is not zero, needed to construct Q
  OneNotZero : NotZero 1
  NegativeNotZero : ( n: Integer ) -> NotZero n -> NotZero (-n)
  PositiveNotZero : ( m: Integer ) -> LTE 1 (fromIntegerNat m)  -> NotZero m

isNotZero : Nat -> Bool
isNotZero Z = False
isNotZero (S k) = True

rational : (p: Nat) -> (q: Integer) -> NotZero q -> (Integer, Integer)
rational Z q x = (toIntegerNat(0), q)
rational (S k) q x = (toIntegerNat(S k), q)

{-
-- snd x can be used instead
SecondPart : (Integer, Integer) -> Integer
SecondPart x = (snd x)
-}

--To simplify rationals to coprime factors, Euclid's algo
gccd : (Integer, Integer) -> Integer
gccd (a, b) = if (isNotZero (toNat b)) then next else a where
  next = gccd (b, toIntegerNat (modNat (toNat a) (toNat b)))

--Lots of casts required to divide by GCD
simplifyRational : (Integer, Integer) -> (Integer, Integer)
simplifyRational (a, b) = (sa, sb) where
  sa = cast {from=Double} {to=Integer} (da / g) where
    da = cast {from=Integer} {to=Double} a
    g = cast {from=Integer} {to=Double} (gccd (a,b))
  sb = cast {from=Double} {to=Integer} (db / g) where
    db = cast {from=Integer} {to=Double} b
    g = cast {from=Integer} {to=Double} (gccd (a,b))

InclusionMap : (n : Nat) -> (Integer, Integer) --Includes the naturals in Q
InclusionMap n = rational n 1 OneNotZero

AddRationals : (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer) --Need to implement proof checking for nonzero denominators
AddRationals x y = simplifyRational ((fst x)*(snd y) + (snd x)*(fst y), (snd x)*(snd y))

MultiplyRationals : (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer) --Need to implement proof checking for nonzero denominators
MultiplyRationals  x y = simplifyRational ((fst x)*(fst y), (snd x)*(snd y))

--Equality of two rationals, needs to be made as a type instead of a bool
eqRat : (Integer, Integer) -> (Integer, Integer) -> Bool
eqRat x y = if ((fst x)*(snd y) == (snd x)*(fst y)) then True else False

--Inverse of a rational (requires proof that denom != 0)
inverseRat : (Integer, Integer) -> (Integer, Integer)
inverseRat x = simplifyRational ((snd x), (fst x))

--To do : Inverses are unique, except for equality (if b1 and b2 are inverses of a, b1 = b2)
--A GCD function with proof that it is the GCD would be useful to reduce rationals into simplified form


twoPlusTwoNotFive : 2 + 2 = 5 -> Void
twoPlusTwoNotFive Refl impossible

equalSuccEqual : S k = S j -> k = j
equalSuccEqual Refl = Refl

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Dec (num1 = num2)
checkEqNat Z Z = Yes Refl
checkEqNat Z (S k) = No (\prf => (case prf of
                                       Refl impossible))

checkEqNat (S k) Z = No (\prf => (case prf of
                                       Refl impossible))

checkEqNat (S k) (S j) = case checkEqNat k j of
                              (Yes prf) => Yes $ cong prf
                              (No contra) => No (contra . equalSuccEqual)

||| Invariant functor
interface Invariant (i : Type -> Type) where
  xmap : (a -> b) -> (b -> a) ->  i a -> i b

Invariant Dec where
  xmap f g (Yes prf) = Yes (f prf)
  xmap f g (No contra) = No (contra . g)

castMap : (Cast a b, Cast b a, Invariant i) => i a -> i b
castMap x = xmap cast cast x

Cast (S k = S j) (k = j) where
  cast Refl = Refl

Cast (k = j) (S k = S j) where
  cast Refl = Refl

checkEqNat2 : (x : Nat) -> (y : Nat) -> Dec (x = y)
checkEqNat2 Z Z = Yes Refl
checkEqNat2 Z (S k) = No (\prf => case prf of
                                       Refl impossible)
checkEqNat2 (S k) Z = No (\prf => case prf of
                                       Refl impossible)
checkEqNat2 (S k) (S j) = castMap (checkEqNat2 k j)

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

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

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

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


module Bezout

import Data.Vect
import Data.Fin

{-Copied from Chinmay's code. Gives quotient and remainder on divison-}
Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat)
Eucl Z b = (0,0)
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 => (0, 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)))


module nattools

%default total

||| Make an isomorphism (of types) Nat to Nat<n + Nat >= n.

||| The natural numbers
--data Nat = Z  | S k

|||----------------------------------------------------------------------------
||| Nat < n.

||| Type of evidence for m < n.
||| Exists k:Nat where m+k+1=n.
data LTProof :  (m:Nat) -> (n:Nat) -> Type where
  MkLTProof : (m:Nat) -> (n:Nat) -> (k:Nat) -> plus m (S k) = n -> LTProof m n

|||-----------------------------------------------------------------------------
||| Nat >= n

||| Type of evidence for  m >= n.
||| Exists k where m = n + k.
data AtLeast : (m:Nat) -> (n:Nat) -> Type where
  MkAtLeast : (m:Nat) -> (n:Nat) -> (k:Nat) -> m = n+k -> AtLeast m n

|||-----------------------------------------------------------------------------
||| Nat -> Nat<n + Nat >= n

||| Type of evidence for  n < m xor m >= n
data SplitNatProof : (n:Nat) -> Type where
  Below : (n:Nat) -> (m:Nat) -> LTProof m n -> SplitNatProof n
  Above : (n:Nat) -> (m:Nat) -> AtLeast m n -> SplitNatProof n

||| have m+(S k)=n  and need (S m)+(S k)=S n
||| Cong {S} e : S ( m + (S k)) = S n  but need to rewrite, LHS.
||| Note, cong will implicitly find the S to apply to both sides by types it
||| has to match.
|||
||| by Plus associative we have (S m) + (S k)= S( m+ (S k))
||| we also have S(m+(S k))=S n
||| By transitivity we get (S m) + (S k) = S n
monotoneBelow : (m : Nat) -> (k : Nat) -> (e : plus m (S k) = n) -> plus (S m) (S k) = S n
monotoneBelow m k e = trans (plusAssociative 1 m (S k)) (cong e)

monotoneAbove : (n : Nat) -> (k : Nat) -> (e : m = (n + k)) -> S m = ((S n) + k)
monotoneAbove n k e = trans (cong e) Refl

monotoneSplit : SplitNatProof n -> SplitNatProof (S n)
monotoneSplit (Below n m (MkLTProof m n k e))  = Below (S n) (S m) (MkLTProof (S m) (S n) k (monotoneBelow m k e))
monotoneSplit (Above n m (MkAtLeast m n k e))  = Above (S n) (S m) (MkAtLeast (S m) (S n) k (monotoneAbove n k e))

||| Split Lemma: For every m:Nat every n:Nat, m < n or m >= n, exclussively
natsSplit : (n:Nat) -> (m:Nat) -> SplitNatProof n
natsSplit Z m = Above 0 m (MkAtLeast m 0 m Refl)
natsSplit (S k) Z = Below (S k) Z (MkLTProof 0  (S k) k Refl)
natsSplit (S k) (S j) = let x = natsSplit k j in (monotoneSplit x)

|||-----------------------------------------------------------------------------
||| Now the isomorphisms, what actually do things.

split : (n:Nat) -> Nat -> DPair Nat (\k=>SplitNatProof n)
split n m = (m**(natsSplit n m))

join : (n:Nat) -> DPair Nat (\k=>SplitNatProof k) -> Nat
join n (m**e) = m

--------------------------------------------------------------------------------
--- TODO: prove these are isomorphisms
--- I.e. join n split n m = m and split n join n x = x


import Data.Vect

plus' : Nat -> Nat -> Nat
plus' Z m = m
plus' (S k) m = S (plus' k m)

fourEq : 4 = 4
fourEq = Refl

twoPlusTwoEqFour : 2 + 2 = 4
twoPlusTwoEqFour = Refl

plusReducesZ : (m : Nat) -> plus' Z m = m
plusReducesZ m = Refl

plusReducesSk : (k, m : Nat) -> plus' (S k) m = S (plus' k m)
plusReducesSk k m = Refl

vectEqLength : (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> n = m
vectEqLength xs xs Refl = Refl

natInduction : (p : Nat -> Type) -> (p Z) -> ((k : Nat) -> p k -> p (S k)) -> (x : Nat) -> p x
natInduction p pZ pS Z = pZ
natInduction p pZ pS (S k) = pS k (natInduction p pZ pS k)

plusInd : Nat -> Nat -> Nat
plusInd n m = natInduction (\x => Nat) m (\k, kRec => S kRec) n

-- plusCommutesZ : m = plus' m 0
-- plusCommutesZ {m = Z} = Refl
-- plusCommutesZ {m = (S k)} =
--     let rec = plusCommutesZ {m = k} in cong rec

-- plusCommutesSk : (k : Nat) -> (m : Nat) -> S (plus' m k) = plus' m (S k)
-- plusCommutesSk k Z = Refl
-- plusCommutesSk k (S j) = cong $ plusCommutesSk k j

-- plusCommutes : (n, m : Nat) -> plus' n m = plus' m n
-- plusCommutes Z m = plusCommutesZ
-- plusCommutes (S k) m = rewrite plusCommutes k m in plusCommutesSk k m

-- plusCommutes : (n, m : Nat) -> plus' n m = plus' m n
-- plusCommutes n m = natInduction (\x => plus' x m = plus' m x) ?rest

plusAssoc : (n, m, p : Nat) -> plus' n (plus' m p) = plus' (plus' n m) p


plusnZ : (n : Nat) -> n + 0 = n
plusnZ 0 = Refl
plusnZ (S k) = rewrite plusnZ k in Refl

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

plusCommutes : (n, m : Nat) -> n + m = m + n
plusCommutes Z m = sym (plusnZ m)
plusCommutes (S k) m = rewrite plusCommutes k m in sym (plusnSm m k)

wrongCommutes : (n, m : Nat) -> n + m = m + n
wrongCommutes Z m = sym (plusnZ m)
wrongCommutes (S k) m = rewrite plusCommutes m k in ?bar

wrongCommutes2 : (n, m : Nat) -> n + m = m + n
wrongCommutes2 Z m = sym (plusnZ m)
wrongCommutes2 (S k) m = rewrite m in ?bar


import Data.Vect

myReverse : Vect n el -> Vect n el
myReverse [] = []
myReverse (x :: xs) = reverseProof (myReverse xs ++ [x])
    where
        reverseProof : Vect (k + 1) el -> Vect (S k) el
        reverseProof {k} result = rewrite plusCommutative 1 k in result

appendNil : Vect m elem -> Vect (plus m 0) elem
appendNil {m} xs = rewrite plusZeroRightNeutral m in xs

appendXs : Vect (S (m + k)) elem -> Vect (plus m (S k)) elem
appendXs {m} {k} xs = rewrite sym (plusSuccRightSucc m k) in xs

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

myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n
myPlusCommutes Z m = sym (plusZeroRightNeutral m)
myPlusCommutes (S k) m = rewrite myPlusCommutes k m in plusSuccRightSucc m k

reverseProofXs : Vect ((S n) + len) el -> Vect (plus n (S len)) el
reverseProofXs {n} {len} result = rewrite sym (plusSuccRightSucc n len) in result

myReverse' : Vect n el -> Vect n el
myReverse' xs = reverse' [] xs where
    reverse' : Vect n el -> Vect m el -> Vect (n + m) el
    reverse' {n} acc [] = rewrite plusZeroRightNeutral n in acc
    reverse' acc (x :: xs) = reverseProofXs (reverse' (x :: acc) xs)


import Data.Vect

-- Data type definition

-- Enumeration
data LightSwitch = On | Off

toggle : LightSwitch -> LightSwitch
toggle On = Off
toggle Off = On

-- Union, basically an email where members can have values
data Shape =
  Triangle Double Double |
  Rectangle Double Double |
  Circle Double

-- Recursive
data Nat2 = Z2 | S Nat2

-- List looks like
-- data List elem = Nil | (::) elem (List elem)

data Tree elem =
  Empty |
  Node (Tree elem) elem (Tree elem)
%name Tree tree, tree2

-- inserting into a binary search tree, not caring about balancing
-- Ord elem => means restrict elem to types that there is an Ord for, so
-- we can compare two values.
insert : Ord elem => elem -> Tree elem -> Tree elem
insert x Empty = Node Empty x Empty
insert x original@(Node left y right) = case compare x y of
  LT => Node (insert x left) y right
  EQ => original
  GT => Node left y (insert x right)

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

-- Exercise 2
treeToList : Tree a -> List a
treeToList Empty = []
treeToList (Node left x right) = treeToList left ++ [x] ++ treeToList right

-- *Chapter4> treeToList (listToTree [4,1,8,7,2,3,5,9,6])
-- [1, 2, 3, 4, 5, 6, 7, 8, 9] : List Integer

-- Exercise 3
data Expr =
  EInt Integer |
  EAdd Expr Expr |
  ESub Expr Expr |
  EMul Expr Expr

-- Exercise 4
evaluate : Expr -> Integer
evaluate (EInt x) = x
evaluate (EAdd x y) = evaluate x + evaluate y
evaluate (ESub x y) = evaluate x - evaluate y
evaluate (EMul x y) = evaluate x * evaluate y

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

-- Exercise 6
-- Biggest triangle's area.
shapeArea : Shape -> Double
shapeArea (Triangle base height) = 0.5 * base * height
shapeArea (Rectangle x y) = x * y
shapeArea (Circle radius) = pi * radius * radius

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

pictureArea : Picture -> Double
pictureArea (Primitive shape) = shapeArea shape
pictureArea (Combine x y) = pictureArea x + pictureArea y
pictureArea (Rotate angle picture) = pictureArea picture
pictureArea (Translate x y picture) = pictureArea picture

biggestTriangle : Picture -> Maybe Double
biggestTriangle (Primitive shape@(Triangle x y)) = Just (shapeArea shape)
biggestTriangle (Primitive (Rectangle x y)) = Nothing
biggestTriangle (Primitive (Circle x)) = Nothing
biggestTriangle (Combine x y) = maxMaybe (biggestTriangle x) (biggestTriangle y)
biggestTriangle (Rotate angle picture) = biggestTriangle picture
biggestTriangle (Translate x y picture) = biggestTriangle picture

-- Dependent Types
-- From Data.Vect
-- data Vect : Nat -> Type -> Type
-- A list whose length is in its type.

data PowerSource = Petrol | Pedal | Electric

data Vehicle : PowerSource -> Type where
  Bicycle : Vehicle Pedal
  Car : (fuel : Nat) -> Vehicle Petrol
  Bus : (fuel : Nat) -> Vehicle Petrol
  Unicycle : Vehicle Pedal
  Motorcycle : (fuel : Nat) -> Vehicle Petrol
  Tram : (wheels : Nat) -> Vehicle Electric

wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4
wheels Unicycle = 1
wheels Motorcycle = 2
wheels (Tram wheels) = wheels

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 200
refuel Bicycle impossible -- compile time check that something wouldn't compile
refuel (Motorcycle fuel) = Motorcycle 50

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

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

index2 : Fin n -> Vect n elem -> elem
index2 FZ (x :: xs) = x
index2 (FS k) (x :: xs) = index2 k xs

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

-- Exercise 3 and 4 (1 and 2 are embedded above)
vectTake : (n : Nat) -> Vect (n + m) elem -> Vect n elem
vectTake Z xs = []
vectTake (S k) (x :: xs) = x :: vectTake k xs

-- Exercise 5
sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries {n} pos xs ys = case integerToFin pos n of
  Nothing => Nothing
  Just index => Just (index2 index xs + index2 index ys)


import Data.Vect

-- Page 219
-- Exercise 1
same_cons : {xs : List a} -> {ys : List a} -> xs = ys -> x :: xs = x :: ys
same_cons Refl = Refl

-- Exercise 2
same_lists : {xs : List a} -> {ys : List a} -> x = y -> xs = ys -> x :: xs = y :: ys
same_lists Refl Refl = Refl

-- Exercise 3
data ThreeEq : a -> b -> c -> Type where
  Same : ThreeEq x x x

-- Exercise 4
allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS x x x (Same) = Same

-- Page 227
-- Exercise 1
myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n
myPlusCommutes Z m = rewrite plusZeroRightNeutral m in Refl
myPlusCommutes (S k) m = rewrite myPlusCommutes k m in
                         rewrite plusSuccRightSucc m k in Refl

reverseProof_xs : Vect (S (n + len)) a -> Vect (n + (S len)) a
reverseProof_xs xs {n} {len} = rewrite sym(plusSuccRightSucc n len) in xs

-- Exercise 2
reverse' : Vect n a -> Vect m a -> Vect (n + m) a
reverse' acc [] {n} = rewrite plusZeroRightNeutral n in acc
reverse' acc (x :: xs) =
        reverseProof_xs (reverse' (x::acc) xs)

myReverse : Vect n a -> Vect n a
myReverse xs = reverse' [] xs

-- Page 234
-- See file `week7_2_234.idr`

-- Page 249
-- Exercise 2

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

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

notLastOne : (contra : (x = value) -> Void) -> Last [x] value -> Void
notLastOne contra LastOne = contra Refl
notLastOne contra (LastCons prf) = noLastEmpty prf

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

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


import Data.Vect

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

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

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

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

maryInVector: Elem "Mary" ["Peter", "Paul", "Mary"]
maryInVector =  There (There Here)

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

last123: Last [1, 2, 3] 3
last123 = LastCons (LastCons LastOne)

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

notTheLastOne : (notLast : (x = value) -> Void) -> Last [x] value -> Void
notTheLastOne notLast LastOne = notLast Refl
notTheLastOne _ (LastCons LastOne) impossible
notTheLastOne _ (LastCons (LastCons _)) impossible

notInListTail : (notInTail : Last (mid :: tail) value -> Void) -> Last (x :: (mid :: tail)) value -> Void
notInListTail notInTail (LastCons prf) = notInTail prf

total isLast: DecEq a => (xs: List a) -> (value: a) -> Dec(Last xs value)
isLast [] value = No notInEmpty
isLast (last :: []) value = case decEq last value of
  (Yes Refl) => Yes LastOne
  (No contra) => No (notTheLastOne contra)
isLast (head :: mid :: tail) value = case isLast (mid :: tail) value of
  (Yes prf) => Yes (LastCons prf)
  (No notInTail) => No (notInListTail notInTail)


module AssRecRule

import Data.Fin
import Data.Vect

--Question 1
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 (z :: xs) = step z xs previous where
  previous = recList a x base step xs

--Question 2
mapList : (a: Type) -> (b: Type) -> (f: a -> b) -> List a -> List b
mapList a b f xs = recList a (List b) base step xs where
  base = []
  step = \u: a => \r: List a => \d: List b => ((f u) :: d)

--Question 3 (this performs left folding, but the element init is evaluated at the end. I believe
--it is possible to perform the operation with 'init' at the beginning, but this would require the
-- the list to be reversed (which could be done with recList))
foldList : (a: Type) ->  (init: a) -> (op : a -> a -> a) -> List a -> a
foldList a init op xs = recList a a base step xs where
  base = init
  step = \u: a => \r: List a => \v: a => op u v

--Question 4
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 previous where
  previous = inducFin xs base step k x

--Question 5
fetchElem : (a: Type) -> (q: Nat) -> (j: Fin q) -> (Vect q a -> a)
fetchElem a q j vs = inducFin (mV a) base step q j vs where

  mV: (a: Type) -> (n: Nat) -> (q: Fin n) -> Type
  mV a n q = (Vect n a -> a)

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

  step: (k: Nat) -> (q: Fin k) -> (f: Vect k a -> a) -> (Vect (S k) a) -> a
  step k q f (x :: xs) = f xs


module BinaryInt

||| A type for binary representation of integers
data Nat2   = Zbit              --  0
            | Ibit              --  1
            | Times2 Nat2       -- x0
            | Times2Plus1 Nat2  -- x1

||| Binary addition, case by case.
(+) : Nat2 -> Nat2 -> Nat2
(+) Zbit y = y                                                      --  0 +  y = y
(+) x Zbit = x                                                      --  x +  0 = x
(+) Ibit Ibit = Times2 Ibit                                         --  1 +  1 = 10
(+) Ibit (Times2 y) = Times2Plus1 y                                 --  1 + y0 = y1
(+) Ibit (Times2Plus1 y) = Times2 ((+) Ibit y)                      --  1 + y1 = (y+1)1
(+) (Times2 x) Ibit = Times2Plus1 x                                 -- x0 +  1 = x1
(+) (Times2 x) (Times2 y) = Times2 ((+) x y)                        -- x0 + y0 = (x+y)0
(+) (Times2 x) (Times2Plus1 y) = Times2Plus1 ((+) x y)              -- x0 + y1 = (x+y)1
(+) (Times2Plus1 x) Ibit = Times2 ((+) x Ibit)                      -- x1 +  1 = (x+1)0
(+) (Times2Plus1 x) (Times2 y) = Times2Plus1 ((+) x y)              -- x1 + y0 = (x+y)1
(+) (Times2Plus1 x) (Times2Plus1 y) = Times2 ((+) x ((+) y Ibit) )  -- x1 + y1 = (x+(y+1))0

||| ---------------------------------------------------------------------------
||| Prove associativity.
||| This is a simple proposition, i.e. a singleton type.
||| ---------------------------------------------------------------------------

assLaw : (x:Nat2) -> (y:Nat2) -> (z:Nat2) -> (+) x ( (+) y z ) = (+) ((+) x y ) z
assLaw x y Zbit = ?xyZbit

||| ---------------------------------------------------------------------------
||| Equality only supported by reflexive constructor `Same`
||| So `Same 5 : EqNat 5 5`  so `EqNat k k` is **always** inhabited.
||| However there is no constructor for `EqNat 4 5` for example, that type
||| exists but is **never** uninhabitted. I.e.
|||
||| *EqNat> the (EqNat 4 4) (Same _)  -- works, 4 replaces _
||| *EqNat> the (EqNat 4 5) (Same _)  -- fails, no solution to _
|||
||| ---------------------------------------------------------------------------
data EqNat : (i:Nat) -> (j:Nat) -> Type where
    Same : (k:Nat) -> EqNat k k

data EqNat2 : (i:Nat2) -> (j:Nat2) -> Type where
    Same2 : (k:Nat2) -> EqNat2 k k

||| ---------------------------------------------------------------------------
||| Function to lift equality inductively.
||| This isn't total but only used on equal inputs in the type checker.
||| ---------------------------------------------------------------------------
--liftEq : (i:Nat) -> (j:Nat) -> (i = j) -> (S i) = (S j)
--liftEq k k Refl = Refl

--liftEqTimes2 : (i:Nat2) -> (j:Nat2) -> (eq:EqNat2 i j) -> EqNat2 (Times2 i) (Times2 j)
--liftEqTimes2 k k (Same2 k) = Same2 (Times2 k)
--liftEqTimes2Plus1 : (i:Nat2) -> (j:Nat2) -> (eq:EqNat2 i j) -> EqNat2 (Times2Plus1 i) (Times2Plus1 j)
--liftEqTimes2Plus1 k k (Same2 k) = Same2 (Times2Plus1 k)

||| ---------------------------------------------------------------------------
||| Check equality and convert to Maybe EqNat
||| As usual define checkEqNat on the various constructors of Nat/Nat2
||| where the behavior is clear.  Makes an total function by induction.
|||
||| checkEqNat 4 5 = Nothing : Maybe EqNat 4 5
||| checkEqNat 4 4 = Just Same 4 : Maybe EqNat 4 4
|||
||| ---------------------------------------------------------------------------
checkEqNat : (i:Nat) -> (j:Nat) -> Maybe( i = j )
checkEqNat Z Z          = Just Refl
checkEqNat (S k) Z      = Nothing
checkEqNat Z (S k)      = Nothing
checkEqNat (S k) (S m)  = case checkEqNat k m of
                            Nothing => Nothing
                            Just prfEq  => Just (cong prfEq)

checkEqNat2 : (i:Nat2) -> (j:Nat2) -> Maybe( i = j )
checkEqNat2 Zbit            Zbit               = Just Refl
checkEqNat2 Ibit            Zbit               = Nothing
checkEqNat2 (Times2 k)      Zbit               = Nothing
checkEqNat2 (Times2Plus1 k) Zbit               = Nothing
checkEqNat2 Ibit            Ibit               = Just Refl
checkEqNat2 (Times2 k)      Ibit               = Nothing
checkEqNat2 (Times2Plus1 k) Ibit               = Nothing
checkEqNat2 (Times2 k)      (Times2 m)           = case checkEqNat2 k m of
                                                    Nothing => Nothing
                                                    Just eq => Just (cong eq)
checkEqNat2 (Times2Plus1 k) (Times2 m)           = Nothing
checkEqNat2 (Times2Plus1 k) (Times2Plus1 m)      = case checkEqNat2 k m of
                                                    Nothing => Nothing
                                                    Just eq => Just (cong eq)

||| ---------------------------------------------------------------------------
||| The Isomorphism binary natural numbers to unary natural numbers
||| ---------------------------------------------------------------------------

btou : Nat2 -> Nat
btou Zbit             = Z
btou Ibit             = S Z
btou (Times2 x)       = (btou x) + (btou x)
btou (Times2Plus1 x)  = S ((btou x) + (btou x))

utob : Nat -> Nat2
utob Z = Zbit
utob (S k) = (utob k) + Ibit

||| ---------------------------------------------------------------------------
||| The proof of Isomorphism
|||
||| Idris does eager evaluation so utob(btou Zbit) = utob Z
||| ---------------------------------------------------------------------------
leftIdBU : (x:Nat2) ->  utob (btou x) = x
leftIdBU Zbit = Refl


module Data.Nat.Views

import Control.WellFounded
import Data.Nat

%default total

||| View for dividing a Nat in half
public export
data Half : Nat -> Type where
     HalfOdd : (n : Nat) -> Half (S (n + n))
     HalfEven : (n : Nat) -> Half (n + n)

||| View for dividing a Nat in half, recursively
public export
data HalfRec : Nat -> Type where
     HalfRecZ : HalfRec Z
     HalfRecEven : (n : Nat) -> (rec : Lazy (HalfRec n)) -> HalfRec (n + n)
     HalfRecOdd : (n : Nat) -> (rec : Lazy (HalfRec n)) -> HalfRec (S (n + n))

||| Covering function for the `Half` view
public export
half : (n : Nat) -> Half n
half Z = HalfEven Z
half (S k) with (half k)
  half (S (S (n + n))) | HalfOdd n = rewrite plusSuccRightSucc (S n) n in
                                           HalfEven (S n)
  half (S (n + n)) | HalfEven n = HalfOdd n

public export
halfRec : (n : Nat) -> HalfRec n
halfRec n with (sizeAccessible n)
  halfRec  Z | acc = HalfRecZ
  halfRec (S n) | acc with (half n)
    halfRec (S (S (k + k))) | Access acc | HalfOdd k
      = rewrite plusSuccRightSucc (S k) k
          in HalfRecEven _ (halfRec (S k) | acc (S k) (LTESucc (LTESucc (lteAddRight _))))
    halfRec (S (k + k)) | Access acc | HalfEven k
      = HalfRecOdd _ (halfRec k | acc k (LTESucc (lteAddRight _)))


module Group_property

import Monoid
import Group
import congruence

%access public export

||| Property 1 - Identity is unique for groups
total
Group_property_1 : (grp : Type) -> ((*) : grp -> grp -> grp) ->
                   (IsGroup grp (*)) -> (e1 : grp) -> (e2 :grp) ->
                   (IsIdentity grp (*) e1) -> (IsIdentity grp (*) e2) ->
                   (e1 = e2)

Group_property_1 grp (*) pf_grp e1 e2 pf1 pf2 = trans (sym(snd (pf2 e1))) (fst (pf1 e2))

||| Property 2 - Inverse of an element is unique
total
Group_property_2 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a : grp) -> (b : grp) -> (c : grp) ->
                   (IsInverse grp (*) (fst(snd pfgrp)) a b) ->
                   (IsInverse grp (*) (fst(snd pfgrp)) a c) -> (b = c)

Group_property_2 grp (*) pfgrp a b c pfb pfc = let
                                               pfAss = fst pfgrp
                                               pfid = (fst (snd pfgrp))
                                               in
                                               rewrite (sym (fst ((snd pfid) b))) in
                                              (rewrite (sym (fst pfc)) in
                                              (rewrite (sym (pfAss b a c)) in
                                              (rewrite (snd pfb) in
                                              (rewrite (snd ((snd pfid) c)) in Refl))))

||| Property 3 - b = c implies a*b = a*c
total
Group_property_3 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a : grp) -> (b : grp) -> (c : grp) -> (b = c) -> (a*b = a*c)
Group_property_3 grp (*) pfgrp a b c pfEq = cong pfEq

||| Property 4 - a*b = a*c implies b = c
total
Group_property_4 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a : grp) -> (b : grp) -> (c : grp) -> (a*b = a*c) -> (b = c)
Group_property_4 grp (*) pfgrp a b c pfEq = let pfid = (fst (snd (snd pfgrp)))
                                                a_inv = fst(Inv_with_pf grp (*) pfgrp a)
                                                pf_inv = snd(Inv_with_pf grp (*) pfgrp a)
                                                pfAss = fst pfgrp
                                                in
                                                (rewrite (sym (snd ((snd pfid) b))) in
                                                (rewrite (sym (snd ((snd pfid) c))) in
                                                (rewrite (sym (snd pf_inv)) in
                                                (rewrite (pfAss a_inv a b) in
                                                (rewrite (pfAss a_inv a c) in
                                                (Group_property_3 grp (*) pfgrp a_inv (a*b) (a*c) pfEq))))))

||| Property 5 - b = c implies b*a = c*a
total
Group_property_5 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a : grp) -> (b : grp) -> (c : grp) -> (b = c) -> ( (b*a) = (c*a) )
Group_property_5 grp (*) pfgrp a b c pfEq = (congruence grp grp b c (\x : grp => x*a) pfEq)

||| Property 6 - b*a = c*a implies b = c
total
Group_property_6 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a : grp) -> (b : grp) -> (c : grp) -> (b*a = c*a) -> (b = c)
Group_property_6 grp (*) pfgrp a b c pfEq = let pfid = (fst (snd (snd pfgrp)))
                                                a_inv = fst(Inv_with_pf grp (*) pfgrp a)
                                                pf_inv = snd(Inv_with_pf grp (*) pfgrp a)
                                                pfAss = fst pfgrp
                                                in
                                                (rewrite (sym (fst ((snd pfid) b))) in
                                                (rewrite (sym (fst ((snd pfid) c))) in
                                                (rewrite (sym (fst pf_inv)) in
                                                (rewrite (sym (pfAss b a a_inv)) in
                                                (rewrite (sym (pfAss c a a_inv)) in
                                                (Group_property_5 grp (*) pfgrp a_inv (b*a) (c*a) pfEq))))))

||| Auxilliary proof 1 - Two idenitities mentioned in the definition of the group
||| (one in (fst (snd pfgrp)) another in (fst (snd (snd pfgrp))) are equal.
total
Group_aux_pf_1 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : (IsGroup grp (*))) ->
                 ( (fst (Group_id grp (*) pfgrp)) = (fst (fst (snd (snd pfgrp)))) )

Group_aux_pf_1 grp (*) pfgrp = let
                               pfid1 = (Group_id grp (*) pfgrp)
                               e1 = (fst pfid1)
                               pf1 = (snd pfid1)
                               pfid2 = (fst (snd (snd pfgrp)))
                               e2 = (fst pfid2)
                               pf2 = (snd pfid2)
                               in
                               (Group_property_1 grp (*) pfgrp e1 e2 pf1 pf2)

||| Property 7 - One sided inverse is two sided inverse
total
Group_property_7 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : (IsGroup grp (*))) -> (a : grp)
                   -> (b : grp) -> ( (a*b) = (fst (Group_id grp (*) pfgrp)) )
                   -> (IsInverse grp (*) (Group_id grp (*) pfgrp) a b)

Group_property_7 grp (*) pfgrp a b pfEq = let
                                          pfid1 = Group_id grp (*) pfgrp -- Identity in IdentityExists
                                          pfid2 = fst (snd (snd pfgrp)) -- Identity in InverseExists
                                          e1 = (fst pfid1)
                                          e2 = (fst pfid2)
                                          a_inv = Inv grp (*) pfgrp a
                                          a_inv_pf = snd (Inv_with_pf grp (*) pfgrp a)
                                          a_inv_pf1 = (fst a_inv_pf) -- Proof that a*a_inv = e2
                                          a_inv_pf2 = (snd a_inv_pf) -- Proof that a_inv*a = e2
                                          pfId_eq = Group_aux_pf_1 grp (*) pfgrp -- proof that e1 = e2
                                          pf1 = trans a_inv_pf1 (sym pfId_eq) -- proof that a*a_inv = e1
                                          pf2 = trans pf1 (sym pfEq) -- proof that a*a_inv = a*b
                                          pf3 = Group_property_4 grp (*) pfgrp a a_inv b pf2 -- proof that a_inv b
                                          pf4 = trans a_inv_pf2 (sym pfId_eq) -- proof that a_inv*a = e1
                                          pf5 = Group_property_5 grp (*) pfgrp a a_inv b pf3 -- proof that a_inv*a = b*a
                                          pf6 = trans (sym pf5) pf4
                                          in
                                          (pfEq, pf6)


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

ZeroNotOdd : IsOdd 0->Void
ZeroNotOdd OneOdd impossible
ZeroNotOdd (SSOdd _ _) impossible

TwoNotOdd : IsOdd 2 ->Void
TwoNotOdd (SSOdd Z OneOdd) impossible
TwoNotOdd (SSOdd Z (SSOdd _ _)) 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 _ _) impossible
nNotEvenAndOdd (S Z) ZEven _ impossible
nNotEvenAndOdd (S Z) (SSEven _ _) _ impossible
nNotEvenAndOdd (S (S k)) (SSEven k x) (SSOdd k y) = nNotEvenAndOdd k x y

oddPlusOddEven : (n:Nat)->(m:Nat)-> IsOdd n ->IsOdd m ->IsEven (add n m)
oddPlusOddEven (S(Z)) m OneOdd y = nOddSnEven m y
oddPlusOddEven (S(S k)) m (SSOdd k x) y = SSEven (add k m) (oddPlusOddEven k m x 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 ->(m:Nat ** (n = (S(double m))))
oddIsSdouble (S(Z)) OneOdd = (Z ** Refl)
oddIsSdouble (S (S k)) (SSOdd k x) = case (oddIsSdouble k x) of
                                          (m ** pf) => ((S m) ** (apNat (\l => S(S l)) k (S(double m)) pf))


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

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

import Data.Vect

removeElem : DecEq a => (value : a) -> (xs : Vect (S n) a) -> Vect n a
removeElem value (x :: xs) = case decEq value x of
                                  (Yes prf) => xs
                                  (No contra) => ?removeElem_rhs_3

maryInVector : Elem "Mary" ["Peter", "Paul", "Mary"]
maryInVector = There (There Here)-}

import Data.Vect

removeElem: (value : a) ->
            (xs : Vect (S n) a) ->
            (prf : Elem value xs) ->
            Vect n a
removeElem value (value :: ys) Here = ys
removeElem value {n = Z} (y :: []) (There later) = absurd later
removeElem value {n = (S k)} (y :: ys) (There later)
                                              = y :: removeElem value ys later
Uninhabited (2 + 2 = 5) where
  uninhabited Refl impossible

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

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


-- examples in "Type-Driven Development with Idris"
-- chapter 8

import Data.Vect

-- check that all functions are total
%default total

--
-- section 8.1
--

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

-- exactLength : (len : Nat) -> (input : Vector m a) -> Maybe (Vector len a)
-- exactLength {m} len input = case m == len of
--                                  False => Nothing
--                                  True => Just ?exactLength_rhs_2

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

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

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just (Same 0)
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = checkEqNat k j >>= Just . (sameS _ _)

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

--
-- section 8.2
--

myReverse : Vect n elem -> Vect n elem
myReverse [] = []
myReverse {n = S k} (x :: xs)
  = let result = myReverse xs ++ [x] in
        rewrite plusCommutative 1 k in result

reverse_proof : (x : elem) -> (xs : Vect len elem) ->
                Vect (len + 1) elem -> Vect (S len) elem
reverse_proof {len} x xs result = rewrite plusCommutative 1 len in result

myReverse' : Vect n elem -> Vect n elem
myReverse' [] = []
myReverse' (x :: xs) = reverse_proof x xs (myReverse' xs ++ [x])

append_nil : (ys : Vect m elem) ->
             Vect (plus m 0) elem
append_nil {m} ys = rewrite plusZeroRightNeutral m in ys

append_xs : Vect (S (m + len)) elem -> Vect (plus m (S len)) elem
append_xs {m} {len} xs = rewrite sym (plusSuccRightSucc m len) in xs

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

--
-- section 8.3
--

twoPlusTwoNotFive : 2 + 2 = 5 -> Void
twoPlusTwoNotFive Refl impossible

valueNotSucc : x = S x -> Void
valueNotSucc Refl impossible

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

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

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

checkEqNat2 : (num1 : Nat) -> (num2 : Nat) -> Dec (num1 = num2)
checkEqNat2 Z Z = Yes Refl
checkEqNat2 Z (S k) = No zeroNotSucc
checkEqNat2 (S k) Z = No succNotZero
checkEqNat2 (S k) (S j) = case checkEqNat2 k j of
                               (Yes prf) => Yes (cong prf)
                               (No contra) => No (noRec contra)

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


> module Data.Fin.Extensions
> import Data.Fin
> import Data.List
> import Data.List.TypeEnumeration

> embedNatAsFin : (n : Nat) -> (m : Nat) -> {pf: LT m n} -> Fin n
> embedNatAsFin Z _ {pf=_} impossible
> embedNatAsFin (S _) Z {pf = _} = FZ
> embedNatAsFin (S j) (S k) {pf = LTESucc x} = FS (embedNatAsFin j k {pf=x})

> Uninhabited (LT (S j) (S Z)) where
>    uninhabited (LTESucc x) = uninhabited x

> getLesserFins : {n:Nat} -> (f : Fin (S n)) -> List (Fin (S n))
> getLesserFins FZ = FZ :: []
> getLesserFins (FS x) = (FS x) :: (getLesserFins (weaken x))

> getLesserFinsContains : (x : Fin (S k)) -> Elem x (getLesserFins (last {n = k}))
> getLesserFinsContains {k = Z} FZ = ?getLesserFinsContains_rhs_3
> getLesserFinsContains {k = Z} (FS x) impossible
> getLesserFinsContains {k = (S k)} x = ?getLesserFinsContains_rhs_2

> natToListFin' : (n : Nat) -> List (Fin (S n))
> natToListFin' t = natToListFinInternal t t {pf=lteRefl} where
>   natToListFinInternal : (k:Nat) -> (l : Nat) -> {auto pf: LT (k) (S l)} -> List (Fin (S l))
>   natToListFinInternal Z Z {pf = _}= [FZ]
>   natToListFinInternal (S j) Z {pf} = absurd (uninhabited pf)
>   natToListFinInternal (S j) m {pf} =
>       let headVal = (embedNatAsFin (S m) (S j) {pf=pf}) in
>           let tailVal = natToListFinInternal j m {pf = (lteSuccLeft pf)} in
>               headVal :: tailVal

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

> natToListFinIsAll : (n : Nat) -> All (getLesserFins (last {n=n}))
> natToListFinIsAll Z =  ?isAll
> natToListFinIsAll (S k) = \f =>
>   case (decEq f (last {n=(S k)})) of
>       Yes pf => ?isAll1
>       No contra => ?isAll2


module Group_property

import Monoid
import Group
import congruence

%access public export

||| Property 1 - Identity is unique for groups
total
Group_property_1 : (grp : Type) -> ((*) : grp -> grp -> grp) ->
                   (IsGroup grp (*)) -> (e1 : grp) -> (e2 :grp) ->
                   (IsIdentity grp (*) e1) -> (IsIdentity grp (*) e2) ->
                   (e1 = e2)

Group_property_1 grp (*) pf_grp e1 e2 pf1 pf2 = trans (sym(snd (pf2 e1))) (fst (pf1 e2))

||| Property 2 - Inverse of an element is unique
total
Group_property_2 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a : grp) -> (b : grp) -> (c : grp) ->
                   (IsInverse grp (*) (fst(snd pfgrp)) a b) ->
                   (IsInverse grp (*) (fst(snd pfgrp)) a c) -> (b = c)

Group_property_2 grp (*) pfgrp a b c pfb pfc = let
                                               pfAss = fst pfgrp
                                               pfid = (fst (snd pfgrp))
                                               in
                                               rewrite (sym (fst ((snd pfid) b))) in
                                              (rewrite (sym (fst pfc)) in
                                              (rewrite (sym (pfAss b a c)) in
                                              (rewrite (snd pfb) in
                                              (rewrite (snd ((snd pfid) c)) in Refl))))

||| Property 3 - b = c implies a*b = a*c
total
Group_property_3 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a : grp) -> (b : grp) -> (c : grp) -> (b = c) -> (a*b = a*c)
Group_property_3 grp (*) pfgrp a b c pfEq = cong pfEq

||| Property 4 - a*b = a*c implies b = c
total
Group_property_4 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a : grp) -> (b : grp) -> (c : grp) -> (a*b = a*c) -> (b = c)
Group_property_4 grp (*) pfgrp a b c pfEq = let pfid = (fst (snd (snd pfgrp)))
                                                a_inv = fst(Inv_with_pf grp (*) pfgrp a)
                                                pf_inv = snd(Inv_with_pf grp (*) pfgrp a)
                                                pfAss = fst pfgrp
                                                in
                                                (rewrite (sym (snd ((snd pfid) b))) in
                                                (rewrite (sym (snd ((snd pfid) c))) in
                                                (rewrite (sym (snd pf_inv)) in
                                                (rewrite (pfAss a_inv a b) in
                                                (rewrite (pfAss a_inv a c) in
                                                (Group_property_3 grp (*) pfgrp a_inv (a*b) (a*c) pfEq))))))

||| Property 5 - b = c implies b*a = c*a
total
Group_property_5 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a : grp) -> (b : grp) -> (c : grp) -> (b = c) -> ( (b*a) = (c*a) )
Group_property_5 grp (*) pfgrp a b c pfEq = (congruence grp grp b c (\x : grp => x*a) pfEq)

||| Property 6 - b*a = c*a implies b = c
total
Group_property_6 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a : grp) -> (b : grp) -> (c : grp) -> (b*a = c*a) -> (b = c)
Group_property_6 grp (*) pfgrp a b c pfEq = let pfid = (fst (snd (snd pfgrp)))
                                                a_inv = fst(Inv_with_pf grp (*) pfgrp a)
                                                pf_inv = snd(Inv_with_pf grp (*) pfgrp a)
                                                pfAss = fst pfgrp
                                                in
                                                (rewrite (sym (fst ((snd pfid) b))) in
                                                (rewrite (sym (fst ((snd pfid) c))) in
                                                (rewrite (sym (fst pf_inv)) in
                                                (rewrite (sym (pfAss b a a_inv)) in
                                                (rewrite (sym (pfAss c a a_inv)) in
                                                (Group_property_5 grp (*) pfgrp a_inv (b*a) (c*a) pfEq))))))

||| Auxilliary proof 1 - Two idenitities mentioned in the definition of the group
||| (one in (fst (snd pfgrp)) another in (fst (snd (snd pfgrp))) are equal.
total
Group_aux_pf_1 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : (IsGroup grp (*))) ->
                 ( (fst (Group_id grp (*) pfgrp)) = (fst (fst (snd (snd pfgrp)))) )

Group_aux_pf_1 grp (*) pfgrp = let
                               pfid1 = (Group_id grp (*) pfgrp)
                               e1 = (fst pfid1)
                               pf1 = (snd pfid1)
                               pfid2 = (fst (snd (snd pfgrp)))
                               e2 = (fst pfid2)
                               pf2 = (snd pfid2)
                               in
                               (Group_property_1 grp (*) pfgrp e1 e2 pf1 pf2)

||| Property 7 - One sided inverse is two sided inverse
total
Group_property_7 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : (IsGroup grp (*))) -> (a : grp)
                   -> (b : grp) -> ( (a*b) = (fst (Group_id grp (*) pfgrp)) )
                   -> (IsInverse grp (*) (Group_id grp (*) pfgrp) a b)

Group_property_7 grp (*) pfgrp a b pfEq = let
                                          pfid1 = Group_id grp (*) pfgrp -- Identity in IdentityExists
                                          pfid2 = fst (snd (snd pfgrp)) -- Identity in InverseExists
                                          e1 = (fst pfid1)
                                          e2 = (fst pfid2)
                                          a_inv = Inv grp (*) pfgrp a
                                          a_inv_pf = snd (Inv_with_pf grp (*) pfgrp a)
                                          a_inv_pf1 = (fst a_inv_pf) -- Proof that a*a_inv = e2
                                          a_inv_pf2 = (snd a_inv_pf) -- Proof that a_inv*a = e2
                                          pfId_eq = Group_aux_pf_1 grp (*) pfgrp -- proof that e1 = e2
                                          pf1 = trans a_inv_pf1 (sym pfId_eq) -- proof that a*a_inv = e1
                                          pf2 = trans pf1 (sym pfEq) -- proof that a*a_inv = a*b
                                          pf3 = Group_property_4 grp (*) pfgrp a a_inv b pf2 -- proof that a_inv b
                                          pf4 = trans a_inv_pf2 (sym pfId_eq) -- proof that a_inv*a = e1
                                          pf5 = Group_property_5 grp (*) pfgrp a a_inv b pf3 -- proof that a_inv*a = b*a
                                          pf6 = trans (sym pf5) pf4
                                          in
                                          (pfEq, pf6)

||| Property 8 - If f : g -> h is group homomorphism then f(inv(a)) = inv(f(a))
total
Group_property_8 : (dom : Type) -> ((*) : dom -> dom -> dom) -> (pfdom : IsGroup dom (*)) ->
                    (cod : Type) -> ((+) : cod -> cod -> cod) -> (pfcod : IsGroup cod (+)) ->
                    (f : dom -> cod) -> (pfhom : (Hom dom (*) pfdom cod (+) pfcod f)) ->
                    (a : dom) -> ( (f (Inv dom (*) pfdom a)) = (Inv cod (+) pfcod (f a)) )

Group_property_8 dom (*) pfdom cod (+) pfcod f pfhom a = let
                                                         pfid1_dom = (fst (snd pfdom))
                                                         e_dom1 = (fst pfid1_dom) -- identity in the IdentityExists
                                                         e_dom1_pf = (snd pfid1_dom) -- proof that e_dom1 is the identity

                                                         pfid2_dom = (fst (snd (snd pfdom)))
                                                         e_dom2 = (fst pfid2_dom) -- identity in the InverseExists
                                                         e_dom2_pf = (snd pfid2_dom) -- prood that it is the identity

                                                         pf_eq_dom_id12 = (Group_property_1 dom (*) pfdom e_dom1 e_dom2
                                                                            e_dom1_pf e_dom2_pf) -- proof that e_dom1 and e_dom2 are equal

                                                         pfid1_cod = (fst (snd pfcod))
                                                         e_cod1 = (fst pfid1_cod) -- identity in the IdentityExists
                                                         e_cod1_pf = (snd pfid1_cod) -- proof that e_cod1 is the identity

                                                         pfid2_cod = (fst (snd (snd pfcod)))
                                                         e_cod2 = (fst pfid2_cod) -- identity in the InverseExists
                                                         e_cod2_pf = (snd pfid2_cod) -- prood that it is the identity

                                                         pf_eq_cod_id12 = (Group_property_1 cod (+) pfcod e_cod1 e_cod2
                                                                            e_cod1_pf e_cod2_pf) -- proof that e_cod1 and e_cod2 are equal

                                                         a_inv_with_pf = snd (snd (snd pfdom)) a -- (Inv_with_pf dom (*) pfdom a)
                                                         a_inv = fst a_inv_with_pf
                                                         b = (f a_inv)
                                                         c = (Inv cod (+) pfcod (f a))

                                                         pf_id_to_id = (fst pfhom)
                                                         pf_res = (snd pfhom)

                                                         --aux_pf1 : ( ( Group_id dom (*) pfdom ) = (fst (snd pfdom)) )
                                                         --aux_pf1 = Refl -- proof that fst (Group_id dom (*) pfdom) = fst (fst (snd pfdom))

                                                         pf1 = (pf_res a a_inv) -- proof that f(a * a_inv) = f a + f a_inv
                                                         pf2 = (fst (snd a_inv_with_pf)) -- proof that a * a_inv = e_dom2
                                                         pf3 = congruence dom cod (a * a_inv) e_dom2 f pf2 -- proof that a * a_inv = e_dom2
                                                         pf4 = trans (sym pf1) pf3 -- proof that f(a * a_inv) = f e_dom2
                                                         pf5 = (Group_property_1 cod (+) pfcod
                                                               (f e_dom1) e_cod1 pf_id_to_id e_cod1_pf) -- proof that f e_dom1 = e_cod1
                                                         pf6 = congruence dom cod e_dom1 e_dom2 f pf_eq_dom_id12-- proof that f e_dom1 = f e_dom2
                                                         pf7 = trans (trans pf4 (sym pf6)) pf5

                                                         in
                                                         (Group_property_2 cod (+) pfcod (f a) b c (pf7,?rhs1) ?rhs2)


module OTP

data Bit : Type where
    ZeroBit : Bit
    OneBit : Bit

xor : Bit -> Bit -> Bit
xor ZeroBit ZeroBit = ZeroBit
xor ZeroBit OneBit = OneBit
xor OneBit ZeroBit = OneBit
xor OneBit OneBit = ZeroBit

data BitVector : Nat -> Type where
    Nil : BitVector Z
    Cons : Bit -> BitVector n -> BitVector (S n)
%name BitVector xs, ys -- hint for automatic naming

bitwiseXor : (n : Nat) -> BitVector n -> BitVector n -> BitVector n
bitwiseXor 0 [] [] = Nil
bitwiseXor (S k) (Cons x xs) (Cons y ys) = Cons (xor x y) (bitwiseXor k xs ys)

otpEncrypt : (n : Nat) -> (message : BitVector n) -> (key : BitVector n) -> BitVector n
otpEncrypt n message key = bitwiseXor n message key

otpDecrypt : (n : Nat) -> (cipherText : BitVector n) -> (key : BitVector n) -> BitVector n
otpDecrypt n cipherText key = bitwiseXor n cipherText key

-- proof below

total xorCancel : (x : Bit) -> (y : Bit) -> xor (xor x y) y = x
xorCancel ZeroBit ZeroBit = Refl
xorCancel ZeroBit OneBit = Refl
xorCancel OneBit ZeroBit = Refl
xorCancel OneBit OneBit = Refl

total
otpCorrect : (n : Nat) -> (msg : BitVector n) -> (ky : BitVector n) -> otpDecrypt n (otpEncrypt n msg ky) ky = msg
otpCorrect 0 [] [] = Refl
otpCorrect (S n) (Cons x xs) (Cons y ys) =
    let xor_eq = xorCancel x y in
    rewrite xor_eq in
    let ih = otpCorrect n xs ys in
    rewrite ih in
    Refl


module rathivrunda.Odds

import Evens

import Intro

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

threeOdd : IsOdd 3
threeOdd = SSOdd (S Z) OneOdd

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

twoEven : IsEven 2
twoEven = SSEven 0 ZEven

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

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

nOddOrEven : (n: Nat) -> Either (IsEven n) (IsOdd n)
nOddOrEven Z = Left ZEven
nOddOrEven (S k) = case (nOddOrEven k) of
                       (Left l) => Right (SEvenOdd k l)
                       (Right r) => Left (SOddEven k r)

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

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

xyz : (f : Nat -> Nat) -> (n : Nat) -> (m : Nat) -> n = m -> f n = f m
xyz f m m (Refl {x = m}) = Refl {x = f m}

OddSdoubleEven : (n: Nat) -> IsOdd n -> (k: Nat ** S (double k) = n)
OddSdoubleEven (S Z) OneOdd = (Z ** Refl {x = 1})
OddSdoubleEven (S (S k)) (SSOdd k x) = step where
  step = case (OddSdoubleEven k x) of
            (m ** pf) => ((S m) ** xyz (\l => S (S l)) (S (double m)) k pf)


module fn_to_vect

import Data.Vect
import Data.Fin

%access public export
%default total
-- module to convert a function to a vectot and a vector to a
-- function

||| Converts a vector to the corresponding function
vect_to_fn : (n : Nat) -> (ty : Type)-> (Vect n ty) ->
             (k : Fin n) -> ty
vect_to_fn n ty v k = index k v

||| Converts a function to the reversed vector
fn_to_vect : (n : Nat) -> (ty : Type) -> ((k : Fin n) -> ty) ->
             (Vect n ty)
fn_to_vect Z ty fn = []
fn_to_vect (S k) ty fn = (fn FZ) ::
      (fn_to_vect k ty smaller) where
          smaller : ((l : Fin k) -> ty)
          smaller l = fn (FS l)
--
-- ||| Converts a function to the corresponding vector
-- fn_to_vect : (n : Nat) -> (ty : Type) -> ((k : Fin n) -> ty) ->
--              (Vect n ty)
-- fn_to_vect n ty fn = fn_to_vect_rev n ty fn
--   -- reverse (fn_to_vect_rev n ty fn)

||| Definition of Matrices using vectors
Mat_Vect : (n : Nat) -> (m : Nat) -> (ty : Type) -> Type
Mat_Vect n m ty = Vect n (Vect m ty)

||| Definition of Matrices using functions
Mat_fn : (n : Nat) -> (m : Nat) -> (ty : Type) -> Type
Mat_fn n m ty = (i : Fin n) -> (j : Fin m) -> ty

||| From a matrix to its corresponding function
Mat_Vect_to_fn : (n : Nat) -> (m : Nat) -> (ty : Type) ->
                 (Mat_Vect n m ty) -> (Mat_fn n m ty)

Mat_Vect_to_fn n m ty vec i j = index j (index i vec)

||| From a function to the corresponding vector
Mat_fn_to_Vect : (n : Nat) -> (m : Nat) -> (ty : Type) ->
                     (Mat_fn n m ty) -> (Mat_Vect n m ty)

Mat_fn_to_Vect Z m ty fn = []
Mat_fn_to_Vect (S n) m ty fn = (v_top :: v_down) where
  fn_top : ( Fin m ) -> ty
  fn_top j = fn FZ j
  v_top : Vect m ty
  v_top = fn_to_vect m ty fn_top
  fn_down : Mat_fn n m ty
  fn_down i j = fn (FS i) j
  v_down : Mat_Vect n m ty
  v_down = Mat_fn_to_Vect n m ty fn_down

Diag_Mat_fn : (n : Nat) -> (ty : Type) ->
              (zero : ty) -> (elem : ty) ->
              (Mat_fn n n ty)
Diag_Mat_fn n ty zero elem i j = case (decEq i j) of
      Yes prf => elem
      No cont => zero

Diag_Mat_Vect : (n : Nat) -> (ty : Type) ->
                (zero : ty) -> (elem : ty) ->
                (Mat_Vect n n ty)
Diag_Mat_Vect n ty zero elem =
      Mat_fn_to_Vect n n ty (Diag_Mat_fn n ty zero elem)

Id_Mat_Nat : (n : Nat) -> Mat_Vect n n Nat
Id_Mat_Nat n = Diag_Mat_Vect n Nat Z (S Z)


module Main

fac : Integer -> Integer
fac 0 = 1
fac n = n*fac(n-1)

binomial : Integer -> Integer -> Integer
binomial n k = divBigInt (fac n) ((fac k)*(fac (n-k)))

sumBinomials : Integer -> Integer
sumBinomials n = foldr (+) 0 (map (\k=>binomial n k) [0..n])

main : IO ()
main = do
	if sumBinomials 1000 - pow 2 1000 == 0
		then putStrLn "OK"
		else putStrLn "ERROR"


module Chapter4

import Chapter3

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

import Decidable.Equality

%default total

-- Section 4.1 --

public export
data Surj : (f : a -> b) -> Type where
  SurjPrf : ((x : a) -> (y ** x = f y)) -> Surj f

export
to_list_not_surj : Not $ (f : a -> List a) -> Surj f
to_list_not_surj surj = let SurjPrf f = surj \x => [x] in
                        let (y ** prf) = f [] in
                        lemma_val_not_nil $ sym prf

public export
EqRefl : Type -> Type
EqRefl a = Eq a => (x : a) -> x == x = True

export
to_set_not_surj : Equality a => EqRefl a -> Not $ (f : a -> InSet a) -> Surj f
to_set_not_surj er surj = let SurjPrf f = surj \x => [x] in
                          let (y ** prf) = f [] in
                          non_empty_is_not_empty (y ** x_in_x_etc y []) $ sym prf

-- Exercise 4.1 --

export
lemma_4_1 : {t, a : ty -> ty -> Type} ->
            (T : (x, y : ty) -> Either (t x y) (t y x)) ->
            (A : (x, y : ty) -> a x y -> a y x -> x = y) ->
            (TA : (x, y : ty) -> t x y -> a x y) ->
            {x, y : ty} -> a x y -> t x y
lemma_4_1 tl al tal axy = case tl x y of
  Left  txy => txy
  Right tyx => rewrite al x y axy $ tal y x tyx in either id id $ tl y y

  -- Alternatively, you can write a proof without usage of `tl y y`:
  --Right tyx => let u = al x y axy $ tal y x tyx in
  --             rewrite u in
  --             rewrite cong (t y) $ sym u in
  --             tyx

-- Exercise 4.2 --

length_of_init : (x : a) -> (xs : List a) -> length (init $ x::xs) = length xs
length_of_init _ []      = Refl
length_of_init _ (x::xs) = rewrite length_of_init x xs in Refl

last_goes_right : (x : a) -> (xs, ys : List a) -> init (x::xs) ++ last (x::xs)::ys = x::xs ++ ys
last_goes_right _ []      _  = Refl
last_goes_right _ (x::xs) ys = rewrite last_goes_right x xs ys in Refl

export
lemma_4_2 : (xs : List a) -> (ys ** zs ** (xs = ys ++ zs, Either (length ys = length zs) (length ys = 1 + length zs)))
lemma_4_2 [] = ([] ** [] ** (Refl, Left Refl))
lemma_4_2 (x::xs) = let (ys ** zs ** (xyz, lengths)) = lemma_4_2 xs in
                    rewrite xyz in
                    case lengths of
                      Left yz => (x::ys ** zs ** rewrite yz in (Refl, Right Refl))
                      Right ySz => let (yh::ytl) = ys in
                                   (x :: init ys ** last ys :: zs ** rewrite length_of_init x ys in
                                                                     rewrite ySz in
                                                                     rewrite last_goes_right yh ytl zs in
                                                                     (Refl, Left Refl))

  -- I did the proof of ex. 4.2 by case analysis rather than by suggesting `take (half $ 1 + length xs) xs` and `drop (half $ 1 + length xs) xs` as
  -- `ys` and `zs` respectively because this solution is simpler for Idris since it does not involve `Nat` division and other arithmetics.
  -- Standard library also seems to not to contain lemmas about `take` and `drop`, thus I need to formulate and prove them myself.
  -- It is possible, but tough.

-- Section 4.4.6 --

export
not_ev_3 : Not $ Ev 3
not_ev_3 (EvSS _) impossible

export
ev_suc_thus_not : Ev (S m) -> Not $ Ev m
ev_suc_thus_not (EvSS x) (EvSS y) = ev_suc_thus_not x y

-- Exercise 4.3 --

export
ev_ss_thus_ev : Ev (S $ S n) -> Ev n
ev_ss_thus_ev (EvSS x) = x

-- Exercise 4.4 --

-- Look to `not_ev_3` above. Solution is the same since there's no special method for __rule inversion__.

-- Exercise 4.5 --

-- Well, the solution is the same as in the chapter 3:
--iter_then_star : Iter r n x y -> Star r x y
--iter_then_star IterZ       = Refl
--iter_then_star (IterS x z) = Step x (iter_then_star z)

-- Exercise 4.6 --

-- `elems` is defined in `Data.InSet.List`.

falseNotTrue : Not (False = True)
falseNotTrue Refl impossible

namespace Exercise_4_6

  export %hint %inline
  UsedEquality : DecEq a => Equality a
  UsedEquality = PropositionalEq

  export
  list_splits : DecEq a => (xs : List a) -> (x : a) -> (x `isin` elems xs = True) -> (ys ** zs ** (xs = ys ++ x :: zs, x `isin` elems ys = False))
  list_splits [] x prf = absurd $ falseNotTrue rewrite sym $ not_in_empty x in prf
  list_splits (y::ys) x prf = case @@(x =?= y) of
    (True  ** p) => ([] ** ys ** (rewrite eq_val_to_prf {x} {y} @{PropositionalEq} p in Refl
                                , rewrite not_in_empty x in Refl))
    (False ** p) => let (subl ** subr ** (eq, f)) = list_splits ys x (is_in_tail x y (elems ys) p prf) in
                    (y::subl ** subr ** (rewrite eq in Refl, not_in_both x y (elems subl) p f))

-- Exercise 4.7 --

public export
balanced : Nat -> List Alpha -> Bool
balanced 0     []     = True
balanced n     (A::w) = balanced (S n) w
balanced (S n) (B::w) = balanced n w
balanced _     _      = False

replicate_appended : (n : Nat) -> (x : a) -> (w : List a) -> replicate n x ++ x::w = x :: replicate n x ++ w
replicate_appended 0     x w = Refl
replicate_appended (S n) x w = rewrite replicate_appended n x w in Refl

list_splits : (u, v, x, y : List a) -> u ++ v = x ++ y -> Either (m ** (u = x ++ m, y = m ++ v)) (m ** (x = u ++ m, v = m ++ y))
list_splits [] _ x  _ prf = Right (x ** (Refl, prf))
list_splits u  _ [] _ prf = Left  (u ** (Refl, sym prf))
list_splits (_::us) v (_::xs) y prf = rewrite fst $ consInjective prf in
                                      case list_splits us v xs y $ snd $ consInjective prf of
                                        Right (m ** (ux, vy)) => rewrite ux in Right (m ** (Refl, vy))
                                        Left  (m ** (ux, vy)) => rewrite ux in Left  (m ** (Refl, vy))

append_is_nil : (l, r : List a) -> l ++ r = [] -> (l = [], r = [])
append_is_nil [] [] Refl = (Refl, Refl)

append_is_singleton : (l, r : List a) -> (x : a) -> [x] = l ++ r -> Either (l = [x], r = []) (l = [], r = [x])
append_is_singleton [] [x] x Refl = Right (Refl, Refl)
append_is_singleton [x] [] x Refl = Left (Refl, Refl)
append_is_singleton [_] (_::_) _ Refl impossible
append_is_singleton (_::_::_) _ _ Refl impossible

analyze_s : S lr -> Either (lr = []) $
                    Either (w ** sw : S w ** lr = [A] ++ w ++ [B])
                           (w ** v ** sw : S w ** sv : S v ** lr = w ++ v)
analyze_s Empty = Left Refl
analyze_s (Asb {w} sw) = Right $ Left (w ** sw ** Refl)
analyze_s (Ss {w} {v} sw sv) = Right $ Right (w ** v ** sw ** sv ** Refl)

s_can_insert_ab : (l, r : List Alpha) -> S (l ++ r) -> S (l ++ [A, B] ++ r)
s_can_insert_ab l r s = case analyze_s s of
                          Left lr_nil => rewrite fst $ append_is_nil l r lr_nil in
                                         rewrite snd $ append_is_nil l r lr_nil in
                                         Asb Empty
                          Right $ Left (w ** sw ** eq) =>
                            case list_splits l r [A] (w ++ [B]) eq of
                              Left (m ** (l_Am, wB_mr)) => rewrite l_Am in case list_splits m r w [B] $ sym wB_mr of
                                Left (k ** (m_wk, kr)) => rewrite m_wk in case append_is_singleton k r B kr of
                                  Left  (kB, rn) => rewrite kB in
                                                    rewrite rn in
                                                    Ss (Asb sw) (Asb Empty)
                                  Right (kn, rB) => rewrite kn in
                                                    rewrite rB in
                                                    rewrite appendNilRightNeutral w in
                                                    rewrite appendAssociative w [A, B] [B] in
                                                    Asb $ Ss sw $ Asb Empty
                                Right (k ** (w_mk, r_kB)) =>
                                  rewrite r_kB in
                                  rewrite appendAssociative m (A::B::k) [B] in
                                  Asb $ s_can_insert_ab (assert_smaller l m) (assert_smaller r k) rewrite sym w_mk in sw
                              Right (m ** (lm, r_mwB)) => rewrite r_mwB in case append_is_singleton l m A lm of
                                Left (lA, mn) => rewrite lA in
                                                 rewrite mn in
                                                 Asb $ Ss (Asb Empty) sw
                                Right (ln, mA) => rewrite ln in
                                                  rewrite mA in
                                                  rewrite sym eq in
                                                  Ss (Asb Empty) s
                          Right $ Right (w ** v ** sw ** sv ** eq) => case list_splits l r w v eq of
                            Left (m ** (l_wm, v_rm)) =>
                              rewrite l_wm in
                              rewrite sym $ appendAssociative w m (A::B::r) in
                              Ss sw $ s_can_insert_ab (assert_smaller l m) r rewrite sym v_rm in sv
                            Right (m ** (w_lm, r_mv)) =>
                              rewrite r_mv in
                              rewrite appendAssociative l (A::B::m) v in
                              flip Ss sv $ s_can_insert_ab l (assert_smaller r m) rewrite sym w_lm in sw

init_last_decomp : (xs : List a) -> {auto ne : NonEmpty xs} -> xs = init xs ++ [last xs]
init_last_decomp (_::[])        = Refl
init_last_decomp (x::xs@(_::_)) = rewrite sym $ init_last_decomp xs in Refl

not_s_start_b : (w : List Alpha) -> Not $ S $ B::w
not_s_start_b _ Empty impossible

not_s_end_a : (w : List Alpha) -> Not $ S $ w ++ [A]
not_s_end_a [] Empty impossible
not_s_end_a (A::_) Empty impossible
not_s_end_a (B::_) Empty impossible

s_can_elim_ab : (l, r : List Alpha) -> S (l ++ [A, B] ++ r) -> S (l ++ r)
s_can_elim_ab [] r s = case analyze_s s of
  Right $ Left (w ** sw ** _) => case w of B::w' => absurd $ not_s_start_b w' sw
  Right $ Right (w ** v ** sw ** sv ** eq) => case w of
    [] => assert_total {-assert_smaller s sv-} $ s_can_elim_ab [] r rewrite eq in sv
    A::B::w' => rewrite snd $ consInjective $ snd $ consInjective eq in
                flip Ss sv $ assert_total {-assert_smaller s sw-} $ s_can_elim_ab [] w' sw
s_can_elim_ab (l::ls) [] s = rewrite appendNilRightNeutral ls in case analyze_s s of
  Right $ Left (w ** sw ** eq) => let u = fst $ snocInjective {xs=ls++[A]} {x=B} {ys=w} {y=B}
                                            rewrite sym $ appendAssociative ls [A] [B] in snd $ consInjective eq in
                                  absurd $ not_s_end_a ls rewrite u in sw
  Right $ Right (w ** v ** sw ** sv ** eq) => case list_splits (l::ls) [A, B] w v eq of
    Left (m ** (lls_wm, v_mAB)) => rewrite lls_wm in
                                   Ss sw $ the (S m) rewrite sym $ appendNilRightNeutral m in
                                             assert_total {-assert_smaller s sv-} s_can_elim_ab m [] rewrite sym v_mAB in sv
    Right (m ** (w_llsm, aB_mv)) => case m of
      [] => let u = fst $ snocInjective {xs=l::ls++[A]} {x=B} {ys=w++[A]} {y=B}
                      rewrite sym $ appendAssociative w [A] [B] in
                      rewrite aB_mv in
                      rewrite sym $ appendAssociative ls [A] [B] in
                      eq in
            rewrite fst $ snocInjective {xs=l::ls} u in sw
      A::m'::ms' => let (_, v_n) = append_is_nil _ _ $ sym $ snd $ consInjective $ snd $ consInjective aB_mv in
                    rewrite sym $ appendNilRightNeutral (l::ls) in
                    assert_total {-assert_smaller s sw-} $ s_can_elim_ab (l::ls) []
                      let u = the ([A, B] = A::m'::ms') $ rewrite sym $ appendNilRightNeutral ms' in rewrite sym v_n in aB_mv in
                      rewrite cong (ls ++) u in
                      rewrite sym w_llsm in
                      sw
s_can_elim_ab (l::ls) (r::rs) s = case analyze_s s of
  Right $ Left (w ** sw ** eq) => rewrite init_last_decomp (r::rs) in
                                  let (eq_l, eqL) = consInjective eq in
                                  let (eq_r, eqR) = snocInjective {xs=ls ++ A::B::init (r::rs)} {x=last $ r::rs} {y=B}
                                                      rewrite sym $ appendAssociative ls (init $ A::B::r::rs) [last $ A::B::r::rs] in
                                                      rewrite sym $ init_last_decomp $ A::B::r::rs in
                                                      eqL in
                                  rewrite eq_l in
                                  rewrite eqR in
                                  rewrite appendAssociative ls (init $ r::rs) [B] in
                                  Asb $ s_can_elim_ab ls (init $ r::rs) rewrite eq_r in sw
  Right $ Right (w ** v ** sw ** sv ** eq) => case list_splits (l::ls) (A::B::r::rs) w v eq of
    Left (m ** (lls_wm, w_ABrrs)) => rewrite cong (++ r::rs) lls_wm in
                                     rewrite sym $ appendAssociative w m (r::rs) in
                                     Ss sw $ assert_total {-assert_smaller s sv-} $ s_can_elim_ab m (r::rs) rewrite sym w_ABrrs in sv
    Right (m ** (w_llsm, aBrrs_mv)) => case m of
      [] => rewrite cong (++ r::rs) $ the (l::ls=w) rewrite sym $ appendNilRightNeutral ls in sym w_llsm in
            Ss sw $ s_can_elim_ab (assert_smaller (l::ls) []) (r::rs) rewrite aBrrs_mv in sv
      A::B::m' => rewrite snd $ consInjective $ snd $ consInjective aBrrs_mv in
                  rewrite appendAssociative (l::ls) m' v in
                  flip Ss sv $ s_can_elim_ab (l::ls) (assert_smaller (r::rs) m') rewrite sym w_llsm in sw
      A::A::_ => case fst $ consInjective $ snd $ consInjective aBrrs_mv of Refl impossible

balanced_appended : (n : Nat) -> (l, r : List Alpha) -> balanced n l = True -> balanced 0 r = True -> balanced n (l ++ r) = True
balanced_appended 0      []    _ _   prf = prf
balanced_appended 0     (A::l) r plf prf = balanced_appended 1 l r plf prf
balanced_appended (S n) (A::l) r plf prf = balanced_appended (S $ S n) l r plf prf
balanced_appended (S n) (B::l) r plf prf = balanced_appended n l r plf prf

-- There are a four statements instead of one because `balanced` is coded with `Bool` but `S.S` is inductive data type.

export
balanced_true_as_s : (n : Nat) -> (w : List Alpha) -> balanced n w = True -> S.S $ replicate n A ++ w
balanced_true_as_s 0     []     _   = Empty
balanced_true_as_s 0     (A::w) prf = balanced_true_as_s 1 w prf
balanced_true_as_s (S n) (A::w) prf = rewrite appendAssociative (replicate (S n) A) [A] w in
                                      rewrite replicate_appended n A [] in
                                      rewrite appendNilRightNeutral $ replicate n A in
                                      balanced_true_as_s (2 + n) w prf
balanced_true_as_s (S n) (B::w) prf = rewrite sym $ replicate_appended n A (B::w) in
                                      s_can_insert_ab (replicate n A) w $ balanced_true_as_s n w prf

export
s_as_balanced_true : (n : Nat) -> (w : List Alpha) -> S.S $ replicate n A ++ w -> balanced n w = True
s_as_balanced_true 0 [] Empty = Refl
s_as_balanced_true 0 (A :: w ++ [B]) (Asb x) = s_as_balanced_true 1 (w ++ [B]) (Asb x)
s_as_balanced_true 0 (w ++ v) (Ss x y) = let xx = assert_total $ s_as_balanced_true 0 w x in
                                         let yy = assert_total $ s_as_balanced_true 0 v y in
                                         balanced_appended 0 w v xx yy
s_as_balanced_true (S n) [] Empty impossible
s_as_balanced_true (S n) (A::w) x = s_as_balanced_true (S $ S n) w rewrite sym $ replicate_appended n A w in x
s_as_balanced_true (S n) (B::w) x = s_as_balanced_true n w $ s_can_elim_ab (replicate n A) w rewrite replicate_appended n A (B::w) in x

export
balanced_false_as_not_s : (n : Nat) -> (w : List Alpha) -> balanced n w = False -> Not $ S.S $ replicate n A ++ w
balanced_false_as_not_s n w prf s = falseNotTrue $ rewrite sym prf in s_as_balanced_true n w s

export
not_s_as_balanced_false : (n : Nat) -> (w : List Alpha) -> Not $ S.S $ replicate n A ++ w -> balanced n w = False
not_s_as_balanced_false n w f = case decEq (balanced n w) False of
  Yes p => p
  No no => absurd $ f $ balanced_true_as_s n w $ notFalseIsTrue no


data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)
%name Tree tree, tree1

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

{-data BSTree : Type -> Type where
     Empty : Ord elem => BSTree elem
     Node : Ord elem => (left : BSTree elem) -> (val : elem) ->
                        (right : BSTree elem) -> BSTree elem

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

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

treeToList : Tree a -> List a
treeToList Empty = []
treeToList (Node left x right) = treeToList left ++ [x] ++ treeToList right

data Expr : Type where
     Val : Int -> Expr
     Add : Expr -> Expr -> Expr
     Sub : Expr -> Expr -> Expr
     Mult : Expr -> Expr -> Expr

evaluate : Expr -> Int
evaluate (Val x) = x
evaluate (Add x y) = evaluate x + evaluate y
evaluate (Sub x y) = evaluate x - evaluate y
evaluate (Mult x y) = evaluate x * evaluate y

maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing Nothing = Nothing
maxMaybe Nothing (Just x) = Just x
maxMaybe (Just x) Nothing = Just x
maxMaybe (Just x) (Just y) = Just (max x y)