module Data.Monoid.Exponentiation

import Data.Nat.Views
import Syntax.PreorderReasoning

%default total

------------------------------------------------------------------------
-- Implementations

public export
linear : Monoid a => a -> Nat -> a
linear v Z = neutral
linear v (S k) = v <+> linear v k

public export
modularRec : Monoid a => a -> HalfRec n -> a
modularRec v HalfRecZ = neutral
modularRec v (HalfRecEven _ acc) = let e = modularRec v acc in e <+> e
modularRec v (HalfRecOdd _ acc) = let e = modularRec v acc in v <+> e <+> e

public export
modular : Monoid a => a -> Nat -> a
modular v n = modularRec v (halfRec n)

infixr 10 ^
public export
(^) : Num a => a -> Nat -> a
(^) = modular @{Multiplicative}

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

-- Not using `MonoidV` because it's cursed
export
linearPlusHomo : (mon : Monoid a) =>
  -- good monoid
  (opAssoc : {0 x, y, z : a} -> ((x <+> y) <+> z) === (x <+> (y <+> z))) ->
  (neutralL : {0 x : a} -> (neutral @{mon} <+> x) === x) ->
  -- result
  (v : a) -> {m, n : Nat} ->
  (linear v m <+> linear v n) === linear v (m + n)
linearPlusHomo opAssoc neutralL v = go m where

  go : (m : Nat) -> (linear v m <+> linear v n) === linear v (m + n)
  go Z = neutralL
  go (S m) = Calc $
    |~ (v <+> linear v m) <+> linear v n
    ~~ v <+> (linear v m <+> linear v n) ...( opAssoc )
    ~~ v <+> (linear v (m + n))          ...( cong (v <+>) (go m) )

export
modularRecCorrect : (mon : Monoid a) =>
    -- good monoid
  (opAssoc : {0 x, y, z : a} -> ((x <+> y) <+> z) === (x <+> (y <+> z))) ->
  (neutralL : {0 x : a} -> (neutral @{mon} <+> x) === x) ->
  -- result
  (v : a) -> {n : Nat} -> (p : HalfRec n) ->
  modularRec v p === linear v n
modularRecCorrect opAssoc neutralL v acc = go acc where

  aux : {m, n : Nat} -> (linear v m <+> linear v n) === linear v (m + n)
  aux = linearPlusHomo opAssoc neutralL v

  go : {n : Nat} -> (p : HalfRec n) -> modularRec v p === linear v n
  go HalfRecZ = Refl
  go (HalfRecEven k acc) = rewrite go acc in aux
  go (HalfRecOdd k acc) = rewrite go acc in Calc $
    |~ (v <+> linear v k) <+> linear v k
    ~~ v <+> (linear v k <+> linear v k)  ...( opAssoc )
    ~~ v <+> (linear v (k + k))           ...( cong (v <+>) aux )

export
modularCorrect : (mon : Monoid a) =>
    -- good monoid
  (opAssoc : {0 x, y, z : a} -> ((x <+> y) <+> z) === (x <+> (y <+> z))) ->
  (neutralL : {0 x : a} -> (neutral @{mon} <+> x) === x) ->
  -- result
  (v : a) -> {n : Nat} -> modular v n === linear v n
modularCorrect opAssoc neutralL v
  = modularRecCorrect opAssoc neutralL v (halfRec n)


||| Properties of Fibonacci functions
module Data.Nat.Fib

import Data.Nat

%default total

||| Recursive definition of Fibonacci.
fibRec : Nat -> Nat
fibRec Z = Z
fibRec (S Z) = S Z
fibRec (S (S k)) = fibRec (S k) + fibRec k

||| Accumulator for fibItr.
fibAcc : Nat -> Nat -> Nat -> Nat
fibAcc Z a _ = a
fibAcc (S k) a b = fibAcc k b (a + b)

||| Iterative definition of Fibonacci.
fibItr : Nat -> Nat
fibItr n = fibAcc n 0 1

||| Addend shuffling lemma.
plusLemma : (a, b, c, d : Nat) -> (a + b) + (c + d) = (a + c) + (b + d)
plusLemma a b c d =
  rewrite sym $ plusAssociative a b (c + d) in
    rewrite plusAssociative b c d in
      rewrite plusCommutative b c in
        rewrite sym $ plusAssociative c b d in
          plusAssociative a c (b + d)

||| Helper lemma for fibacc.
fibAdd : (n, a, b, c, d : Nat) ->
  fibAcc n a b + fibAcc n c d = fibAcc n (a + c) (b + d)
fibAdd Z _ _ _ _ = Refl
fibAdd (S Z) _ _ _ _ = Refl
fibAdd (S (S k)) a b c d =
  rewrite fibAdd k (a + b) (b + (a + b)) (c + d) (d + (c + d)) in
    rewrite plusLemma b (a + b) d (c + d) in
      rewrite plusLemma a b c d in
        Refl

||| Iterative and recursive Fibonacci definitions are equivalent.
fibEq : (n : Nat) -> fibRec n = fibItr n
fibEq Z = Refl
fibEq (S Z) = Refl
fibEq (S (S k)) =
  rewrite fibEq k in
    rewrite fibEq (S k) in
      fibAdd k 1 1 0 1


module AppendVec

import Data.Nat
import Data.Vect

%default total

-- this works since the order of `n` and `m` follow the definition of `plus`
{-
append : Vect n elem -> Vect m elem -> Vect (n + m) elem
append [] ys = ys
append (x :: xs) ys = x :: append xs ys
-}

-- if we change up the order of `n` and `m`, the we have to prove that the
-- addition still holds

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

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

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


--module Data.Iso
module Iso

import Data.DPair
import Data.Nat
import Data.Fin
import Data.Fin.Extra

import Syntax.WithProof

%default total

-- TODO to think of weaker form of isomorphism:
--  0 to_from_to_is_from : (x : a) -> to (from (to x)) = to x
--  0 from_to_from_is_to : (y : b) -> from (to (from y)) = from y

infix 0 =~=

public export
interface (=~=) a b where
  constructor MkIso

  to   : a -> b
  from : b -> a

  0 from_to_id : (x : a) -> from (to x) = x
  0 to_from_id : (y : b) -> to (from y) = y

public export
(=~=) (Fin n) (Subset Nat (`LT` n)) where
  to {n=S k} FZ = Element Z (LTESucc LTEZero)
  to (FS x)     = bimap S LTESucc $ to x

  from = uncurry natToFinLTE

  from_to_id FZ = Refl
  from_to_id {n=S k} (FS x) with (from_to_id {b=Subset Nat (`LT` k)} x)
    from_to_id (FS x) | fti with (to {b=Subset Nat (`LT` k)} x)
      from_to_id (FS x) | fti | Element fst snd = rewrite fti in Refl

  to_from_id (Element Z (LTESucc LTEZero)) = Refl
  to_from_id {n=S n} (Element (S k) (LTESucc x)) = rewrite to_from_id {a=Fin n} {b=Subset Nat (`LT` n)} (Element k x) in Refl
  to_from_id (Element (S k) LTEZero) impossible


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


module RUS

import Data.Vect
import QStateT
import QuantumOp
import LinearTypes
import Unitary
import Data.List

||| Problem: Given an input qubit |q> and a single-qubit unitary operation U,
|||          return the state U|q>. The "Repeat Until Success" approach solves
|||          this problem in the following way:
|||
||| 1. Prepare a new qubit in state |0>
||| 2. Apply some two-qubit unitary operation U' (depends on U)
||| 3. Measure the auxiliary qubit
||| 4. With (high) probability the result is now U|q> and then stop.
||| 5. With (low) probability the result is state E|q>, where E is some other unitary operator
|||    (depending on U), so we uncompute the error by applying E^dagger and we go back to step 1.

export
RUS : QuantumOp t => (1 _ : Qubit) -> (u' : Unitary 2) -> (e : Unitary 1) -> QStateT (t 1) (t 1) Qubit
RUS q u' e = do
  q' <- newQubit
  [q',q] <- applyUnitary [q',q] u'
  b <- measureQubit q'
  if b then do
         [q] <- applyUnitary [q] (adjoint e)
         RUS q u' e
       else pure q

||| Figure 8 of https://arxiv.org/abs/1311.1074
example_u' : Unitary 2
example_u' = H 0 $ T 0 $ CNOT 0 1 $ H 0 $ CNOT 0 1 $ T 0 $ H 0 IdGate

export
runRUS : QuantumOp t => IO Bool
runRUS = do
  [b] <- run (do
              q <- newQubit {t = t}
              q <- RUS q example_u' IdGate
              measure [q]
         )
  pure b

export
testRUS : IO Bool
testRUS = runRUS {t = SimulatedOp}

export
testMultipleRUS : Nat -> IO ()
testMultipleRUS n = do
  let f = testRUS
  s <- sequence (Data.List.replicate n f)
  let heads = filter (== True) s
  putStrLn $ "Number of '1' outcomes: " ++ (show (length heads)) ++ " out of " ++ (show n) ++ " measurements."


||| Algebra.Semigroup: A representation of semigroups.
|||
||| A semigroup is an associative magma. In other words, it is a pair
||| \\(\mathscr{S}=(S:\mathscr{V},\*:S^2\to S)\\) satisfying the following
||| (rather short!) list of axioms:
|||
||| * \\((x\*y)\*z = x\*(y\*z)\\)
|||
||| In addition to interesting combinatorial questions (like those exhibited by
||| magmas; see `Algebra.Magma`), semigroups, with their richer structure, yield
||| more interesting behavior.
|||
||| TODO: expand
module Algebra.Semigroup

import Data.ZZ
import Algebra.Magma

%default total
%hide Semigroup

-- infixr 7 |*|

||| Semigroup: The record representing semigroups.
|||
||| The requirement that a semigroup be a magma is just a declaration of the
||| signature of semigroups; namely, one set and one binary operation over it.
||| There is one law that must be obeyed: associativity. Note that you cannot
||| even construct a semigroup until you have proven that the magma is indeed
||| associative. Thus, the associativity is guaranteed by the typechecker; if a
||| function utilizing a type that claims to be a semigroup, you know that it
||| indeed must be one. mathematically speaking, iff it typechecks. (Of course,
||| as usual, this only holds when all of one's proofs are total.)
export
record Semigroup where
  constructor MkSemigroup'
  magma : Magma
  { assoc : {s,t,u : Set {magma}} -> s |*| (t |*| u) = (s |*| t) |*| u }

export
MkSemigroup : (T : Type) -> (op : T -> T -> T) -> {auto assoc : {s,t,u : T} -> s `op` (t `op` u) = (s `op` t) `op` u} -> Semigroup
MkSemigroup t op {assoc} = MkSemigroup' (MkMagma t op) {assoc=assoc}
{-
public export
MkSemigroup : (T : Type) -> (op : T -> T -> T) -> {auto asc : {s,t,u : T} -> op s (op t u) = op (op s t) u} -> Semigroup
MkSemigroup set op {asc} = MkSemigroup' (MkMagma set op) asc
-}

-- toInteger : ZZ -> Integer
-- toInteger (Pos  n) = toIntegerNat n
-- toInteger (NegS n) = -(toIntegerNat (S n))

%hint
plusAssociative' : {a,b,c : Nat} -> a + (b + c) = (a + b) + c
plusAssociative' {a} {b} {c} = plusAssociative a b c

%hint
multAssociative' : {a,b,c : Nat} -> a * (b * c) = (a * b) * c
multAssociative' {a} {b} {c} = multAssociative a b c

%hint
plusAssociativeZ' : {a,b,c : ZZ} -> a + (b + c) = (a + b) + c
plusAssociativeZ' {a} {b} {c} = plusAssociativeZ a b c

%hint
multAssociativeZ' : {a,b,c : ZZ} -> a * (b * c) = (a * b) * c
multAssociativeZ' {a} {b} {c} = multAssociativeZ a b c

NatAddSemi : Semigroup
NatAddSemi = MkSemigroup Nat (+)
{-
export
NatAddMagma : Magma
NatAddMagma = MkMagma Nat (+)

-- export
-- NatAddSemi : Semigroup
-- NatAddSemi = MkSemigroup NatAddMagma

export NatMultSemi : Semigroup
NatMultSemi = MkSemigroup Nat (*)     -- what the hell

-- SemigroupToMagma : Semigroup -> Magma
-- SemigroupToMagma (

-- export IntAddSemi : Semigroup
-- IntAddSemi = MkSemigroup ZZ (+)

-- export IntMultSemi : Semigroup
-- IntMultSemi = MkSemigroup ZZ (*)
-- -}


module ZZUtils
import ZZ
import NatUtils
%access public export
%default total

data IsNonNegative : ZZ->Type where
 NonNegative :(IsNonNegative (Pos k))

data NotBothZeroZ :ZZ->ZZ->Type where
  LeftPositive :NotBothZeroZ (Pos (S k)) m
  LeftNegative :NotBothZeroZ (NegS k) m
  RightPositive :NotBothZeroZ m (Pos (S k))
  RightNegative :NotBothZeroZ m (NegS k)

data NotZero:ZZ->Type where
  PositiveZ:NotZero (Pos (S k))
  NegativeZ:NotZero (NegS k)

|||Proof that negative integers are not non negative
negsAreNotNonNegs:(IsNonNegative (NegS k))->Void
negsAreNotNonNegs NonNegative impossible
|||A function that checks whether an integer is non negative and returns a
|||proof or a contradiction
decideIsNonNeg:(a: ZZ) -> Dec (IsNonNegative   a)
decideIsNonNeg (Pos k) = Yes NonNegative
decideIsNonNeg (NegS k) = No (negsAreNotNonNegs)
|||Proof that natural numbers are non negative
naturalsNonNegative: (x:Nat)->IsNonNegative (Pos x)
naturalsNonNegative x = NonNegative

|||The less than type for ZZ
LTZ :ZZ->ZZ->Type
LTZ a b = LTEZ (1+a) b

|||Theorem that if a and b are natural numbers and a<b
|||then, (Pos a) <(Pos b)
ltNatToZZ:{a:Nat}->{b:Nat}->(LT a b)->(LTZ (Pos a) (Pos b))
ltNatToZZ (LTESucc x) = PositiveLTE (LTESucc x)
|||Multiplying positive numbers gives a positive number.
posMultPosIsPos: (IsPositive m)->(IsPositive d)->(IsPositive (m*d))
posMultPosIsPos{m = (Pos (S k))}{d = (Pos (S j))} Positive Positive = Positive
|||The theorem that (-a)*(-b)=a*b
negateMultNegateNeutralZ: {a:ZZ}->{b:ZZ}->((-a)*(-b)=a*b)
negateMultNegateNeutralZ{a}{b} =
  rewrite (multNegateRightZ (-a) b) in
  rewrite (multNegateLeftZ a b ) in
  rewrite (doubleNegElim (a*b)) in Refl
|||Proof that zero times an integer is not positive
posIsNotZeroTimesInteger:((Pos (S k))=(Pos Z)*a)->Void
posIsNotZeroTimesInteger{a = (Pos _)} Refl impossible
posIsNotZeroTimesInteger{a = (NegS _)} Refl impossible
|||Proof that Zero times an integer is not negative
negSIsNotZeroTimesInteger :((NegS k)=(Pos Z)*a)->Void
negSIsNotZeroTimesInteger {a = (Pos _)} Refl impossible
negSIsNotZeroTimesInteger {a = (NegS _)} Refl impossible
|||Converts a nonNegative integer into the corresponding Natural number
nonNegIntegerToNat:(a:ZZ)->(IsNonNegative a)->Nat
nonNegIntegerToNat (Pos k) NonNegative = k


module Exercise_5_2_11

import Ch05.LambdaCalculusWithArith

%default total

-- The implementation below is the simple (and naive) one
||| Term representing a function that, given a list of Church numerals (encoded as in ex. 5.2.8),
||| will return their sum
listsum_naive : Term
listsum_naive = lambda 0
                       (\l => l . plus . church_zero)

-- The implementation below uses the fix-point combinator
||| Term representing a function that, given a list of Church numerals (encoded as in ex. 5.2.8),
||| will return their sum
listsum : Term
listsum = fix . g where
  g : Term
  g = lambda 0
             (\f => (lambda 1
                            (\l => IfThenElse (realbool . (isnil . l))
                                              church_zero
                                              (plus . (head . l) . (f . (tail . l))))))


module Chapter3

import Data.Vect

-- In this chapter we do interactive development using the
-- "type, define, refine" loop

allLengths : List String -> List Nat  -- <leader>_d
--allLengths xs = ?allLengths_rhs       -- <leader>_c over xs
allLengths [] = []
--allLengths (word :: words) = ?allLengths_rhs_2       -- <leader>_c
--allLengths (word :: words) = length word :: ?rest
-- <l>_e allLengths
-- ["abc", "cde"] will give partial evaluation
allLengths (word :: words) = length word :: allLengths words

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

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

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

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

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

-- [1,2] is syntactic sugar to ANY datatype with :: and Nil constructors
-- the (Vect _ _) [1,2,3]
-- the (List _) [1,2]
total allLengths2 : Vect n String -> Vect n Nat  -- note we can annotate 'total'
-- (it is still attempted to be inferred by Idris)
allLengths2 [] = []
allLengths2 (x :: xs) = length x :: allLengths2 xs

allLengths3 : Vect n String -> Vect n Nat
allLengths3 [] = []
allLengths3 (word :: words) = length word :: allLengths3 words

-- See VecSort.idr

--createEmpties : Vect n (Vect 0 elem)
--createEmpties = replicate _ []  -- forced by the type to have n elements.
--
--transposeHelper : (x : Vect n elem) -> (xsTrans : Vect n (Vect len elem)) -> Vect n (Vect (S len) elem)
--transposeHelper [] [] = []
--transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys
--
--transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
--transposeMat [] = createEmpties
--transposeMat (x :: xs) = let xsTrans = transposeMat xs in
--                             transposeHelper x xsTrans

--transposeHelper : Vect m elem -> Vect m (Vect len elem) -> Vect m (Vect (S len) elem)
--transposeHelper [] [] = []
--transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys
--
--transposeMat : Vect n (Vect m elem) -> Vect m (Vect n elem)
--transposeMat [] = replicate _ []
--transposeMat (x :: xs) = let xsTrans = transposeMat xs in
--                             transposeHelper x xsTrans

-- Exercises
-- ex1
transposeMat : Vect n (Vect m a) -> Vect m (Vect n a)
transposeMat [] = replicate _ []
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
--                           zipWith ?f x xsTrans  -- Did I say how much I love this language?
                             zipWith (::) x xsTrans

transposeMat2 : Vect n (Vect m a) -> Vect m (Vect n a)
transposeMat2 [] = replicate _ []
transposeMat2 (x :: xs) = zipWith (::) x (transposeMat2 xs)

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

addMatrix2 : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
addMatrix2 = zipWith (zipWith (+))  -- <3

--ex3 (without using transpose)
-- instead we rely on the observation that the result matrix's
-- first row is equal to first row of m1 times m2; hence
-- m1 x m2 = map (rowMult m2) m1
multMatrix : Num a => Vect n (Vect m a) -> Vect m (Vect p a) -> Vect n (Vect p a)
multMatrix m1 m2 = map (flip rowMult m2) m1
  where
    rowMult : Num a => Vect m a -> Vect m (Vect p a) -> Vect p a
    rowMult xs ms = foldr (zipWith (+)) (replicate _ 0) $ zipWith (\x,r => map (*x) r) xs ms

-- Type-level variables
-- Note how we were already were passing elem as an implicit argument.
myAppend : (elem : Type) -> (n : Nat) -> (m : Nat) -> Vect n elem -> Vect m elem -> Vect (n + m) elem
myAppend elem Z m [] ys = ys
myAppend elem (S len) m (x :: xs) ys = x :: myAppend elem len m xs ys

myLength : Vect n a -> Nat
myLength {n} xs = n  -- So much nicer than haskell!

createEmpties2 : Vect n (Vect 0 a)
createEmpties2 {n} = replicate n []

createEmpties3 : Vect n (Vect 0 a)
createEmpties3 {n = Z} = []
createEmpties3 {n = (S k)} = [] :: createEmpties3 {n = k}

createEmpties4 : Vect n (Vect 0 a)
createEmpties4 {n = Z} = []
createEmpties4 {n = (S k)} = [] :: createEmpties4  -- Wooot


||| Algebra.Monoid: A representation of monoids.
|||
||| A monoid is an associative unital magma (i.e., a unital semigroup).
||| Mathematically, one has a pair \\(\mathscr{N} = (N, \*)\\) satisfying:
|||
||| * \\((x*y)*z = x*(y*z)\\)
||| * \\(\exists e \in N [ \forall x \in N [ x*e = e*x = x ]]\\)
|||
||| Monoids strike a nice balance between generality and richness of structure;
||| many naturally-occuring magmas are indeed monoids. For example, consider the
||| set of functions \\(X \to X\\). This set always forms a monoid under
||| function composition (i.e., \\(\* \coloneqq \circ\\))! Everything has the
||| required type (the composition of two functions in \\(X \to X\\) is another
||| such function), the identity, of course, is the identity function
||| \\(\mathrm{id}\\), and function composition is always associative (applying
||| f, then applying (g then h) is the same as applying (f then g), then
||| applying h). Thus, we have a monoid.
|||
||| Another simplr monoid is the set of strings over a given alphabet, with
||| string concatenation as the function (and the empty string
||| \\(\varepsilon\\)) as the identity. Again, this obviously must be monoidal,
||| since string concatenation is clearly associative.
|||
||| TODO: add a little more
module Algebra.Monoid

import Algebra.Magma
import Algebra.Semigroup

%default total

export
record Monoid where
  constructor MkMonoid'
  magma  : Magma
  ID     : Set {magma}
  {assoc : {s,t,u : Set {magma}} -> s |*| (t |*| u) = (s |*| t) |*| u}
  {idl   : {n : Set {magma}} -> (ID |*| n  = n)}
  {idr   : {n : Set {magma}} -> (n  |*| ID = n)}

MkMonoid : (set : Type) -> (op : set -> set -> set) -> (i : set)
             -> {auto assoc : {s,t,u : set} -> s `op` (t `op` u) = (s `op` t) `op` u}
             -> {auto idl   : {n : set} -> (i `op` n = n)}
             -> {auto idr   : {n : set} -> (n `op` i = n)}
             -> Monoid
MkMonoid set op i {assoc} {idl} {idr} = MkMonoid' (MkMagma set op) i {assoc} {idl} {idr}

FuncMonoid : {a : Type} -> Monoid
FuncMonoid {a} = MkMonoid (a -> a) (.) (id)

%hint
listIdr : {a : Type} -> {xs : List a} -> xs ++ [] = xs
listIdr {xs = []}      = Refl
listIdr {xs = (x::xr)} = cong listIdr

%hint
listAssoc : {a : Type} -> {xs,ys,zs : List a} -> xs ++ (ys ++ zs) = (xs ++ ys) ++ zs
listAssoc {xs=[]}      {ys} {zs} = Refl
listAssoc {xs=(x::xr)} {ys} {zs} = cong listAssoc

ListMonoid : {a : Type} -> Monoid
ListMonoid {a} = MkMonoid (List a) (++) []

MonoidToSemigroup : Monoid -> Semigroup
MonoidToSemigroup monoid = MkSemigroup Set (|*|) {assoc = assoc monoid}
--
{-
export
interface Magma N op => Monoid (N : Type) (op : N -> N -> N) (e : N) where
  assoc : {n,p,q : N} -> ((n `op` p) `op` q = n `op` (p `op` q))
  idl : {n : N} -> (n `op` e = n)
  idr : {n : N} -> (e `op` n = n)

_e : Monoid n op e -> n
_e _ = e

export
e : (Monoid n op e) => n
e @{monoid} = _e monoid

-- idk why this isn't working. try the forums, i guess.
-- Algebra.Monoid.Monoid n op ide => Algebra.Semigroup.Semigroup n op where
--   assoc = assoc
-}


= Lists : Working with Structured Data

> module Lists

> import Basics

> %hide Prelude.Basics.fst
> %hide Prelude.Basics.snd
> %hide Prelude.Nat.pred
> %hide Prelude.List.(++)

> %access public export
> %default total

== Pairs of Numbers

In an inductive type definition, each constructor can take any number of
arguments -- none (as with \idr{True} and \idr{Z}), one (as with \idr{S}), or
more than one, as here:

> data NatProd : Type where
>   Pair : Nat -> Nat -> NatProd

This declaration can be read: "There is just one way to construct a pair of
numbers: by applying the constructor \idr{Pair} to two arguments of type
\idr{Nat}."

```idris
λΠ> :t Pair 3 5
```

Here are two simple functions for extracting the first and second components of
a pair. The definitions also illustrate how to do pattern matching on
two-argument constructors.

> fst : (p : NatProd) -> Nat
> fst (Pair x y) = x

> snd : (p : NatProd) -> Nat
> snd (Pair x y) = y

```idris
λΠ> fst (Pair 3 5)
3 : Nat
```

Since pairs are used quite a bit, it is nice to be able to write them with the
standard mathematical notation \idr{(x,y)} instead of \idr{Pair x y}. We can
tell Idris to allow this with a \idr{syntax} declaration.

> syntax "(" [x] "," [y] ")" = Pair x y

The new pair notation can be used both in expressions and in pattern matches
(indeed, we've actually seen this already in the previous chapter, in the
definition of the \idr{minus} function -- this works because the pair notation
is also provided as part of the standard library):

```idris
λΠ> fst (3,5)
3 : Nat
```

> fst' : (p : NatProd) -> Nat
> fst' (x,y) = x

> snd' : (p : NatProd) -> Nat
> snd' (x,y) = y

> swap_pair : (p : NatProd) -> NatProd
> swap_pair (x,y) = (y,x)

Let's try to prove a few simple facts about pairs.

If we state things in a particular (and slightly peculiar) way, we can complete
proofs with just reflexivity (and its built-in simplification):

> surjective_pairing' : (n,m : Nat) -> (n,m) = (fst (n,m), snd (n,m))
> surjective_pairing' n m = Refl

But \idr{Refl} is not enough if we state the lemma in a more natural way:

```idris
surjective_pairing_stuck : (p : NatProd) -> p = (fst p, snd p)
surjective_pairing_stuck p = Refl
```
```
When checking right hand side of
  surjective_pairing_stuck with expected type p = Pair (fst p) (snd p)
...
Type mismatch between p and Pair (fst p) (snd p)
```

We have to expose the structure of \idr{p} so that Idris can perform the pattern
match in \idr{fst} and \idr{snd}. We can do this with \idr{case}.

> surjective_pairing : (p : NatProd) -> p = (fst p, snd p)
> surjective_pairing p = case p of (n,m) => Refl

Notice that \idr{case} matches just one pattern here. That's because
\idr{NatProd}s can only be constructed in one way.

=== Exercise: 1 star (snd_fst_is_swap)

> snd_fst_is_swap : (p : NatProd) -> (snd p, fst p) = swap_pair p
> snd_fst_is_swap p = ?snd_fst_is_swap_rhs

$\square$

=== Exercise: 1 star, optional (fst_swap_is_snd)

> fst_swap_is_snd : (p : NatProd) -> fst (swap_pair p) = snd p
> fst_swap_is_snd p = ?fst_swap_is_snd_rhs

$\square$

== Lists of Numbers

Generalizing the definition of pairs, we can describe the type of _lists_ of
numbers like this: "A list is either the empty list or else a pair of a number
and another list."

> data NatList : Type where
>   Nil : NatList
>   (::) : Nat -> NatList -> NatList

For example, here is a three-element list:

> mylist : NatList
> mylist = (::) 1 ((::) 2 ((::) 3 Nil))

\todo[inline]{Edit the section - Idris's list sugar automatically works for
anything with constructors \idr{Nil} and \idr{(::)}}

As with pairs, it is more convenient to write lists in familiar programming
notation. The following declarations allow us to use \idr{::} as an infix Cons
operator and square brackets as an "outfix" notation for constructing lists.

It is not necessary to understand the details of these declarations, but in case
you are interested, here is roughly what's going on. The right associativity
annotation tells Coq how to parenthesize expressions involving several uses of
:: so that, for example, the next three declarations mean exactly the same
thing:

> mylist1 : NatList
> mylist1 = 1 :: (2 :: (3 :: Nil))

> mylist2 : NatList
> mylist2 = 1::2::3::[]

> mylist3 : NatList
> mylist3 = [1,2,3]

The at level 60 part tells Coq how to parenthesize expressions that involve both
:: and some other infix operator. For example, since we defined + as infix
notation for the plus function at level 50,

```coq
Notation "x + y" := ( plus x y )
( at level 50, left associativity ).
```

the `+` operator will bind tighter than `::` , so `1 + 2 :: [3]` will be parsed,
as we'd expect, as `(1 + 2) :: [3]` rather than `1 + (2 :: [3])`.

(Expressions like "`1 + 2 :: [3]`" can be a little confusing when you read them
in a `.v` file. The inner brackets, around `3`, indicate a list, but the outer
brackets, which are invisible in the HTML rendering, are there to instruct the
"coqdoc" tool that the bracketed part should be displayed as Coq code rather
than running text.)

The second and third `Notation` declarations above introduce the standard
square-bracket notation for lists; the right-hand side of the third one
illustrates Coq's syntax for declaring n-ary notations and translating them to
nested sequences of binary constructors.

=== Repeat

A number of functions are useful for manipulating lists. For example, the
\idr{repeat} function takes a number \idr{n} and a \idr{count} and returns a
list of length \idr{count} where every element is \idr{n}.

> repeat : (n, count : Nat) -> NatList
> repeat n Z = []
> repeat n (S k) = n :: repeat n k

=== Length

The \idr{length} function calculates the length of a list.

> length : (l : NatList) -> Nat
> length [] = Z
> length (h :: t) = S (length t)

=== Append

The \idr{app} function concatenates (appends) two lists.

> app : (l1, l2 : NatList) -> NatList
> app [] l2 = l2
> app (h :: t) l2 = h :: app t l2

Actually, \idr{app} will be used a lot in some parts of what follows, so it is
convenient to have an infix operator for it.

> infixr 7 ++

> (++) : (x, y : NatList) -> NatList
> (++) = app

> test_app1 : [1,2,3] ++ [4,5,6] = [1,2,3,4,5,6]
> test_app1 = Refl

> test_app2 : [] ++ [4,5] = [4,5]
> test_app2 = Refl

> test_app3 : [1,2,3] ++ [] = [1,2,3]
> test_app3 = Refl

=== Head (with default) and Tail

Here are two smaller examples of programming with lists. The \idr{hd} function
returns the first element (the "head") of the list, while \idr{tl} returns
everything but the first element (the "tail"). Of course, the empty list has no
first element, so we must pass a default value to be returned in that case.

> hd : (default : Nat) -> (l : NatList) -> Nat
> hd default [] = default
> hd default (h :: t) = h

> tl : (l : NatList) -> NatList
> tl [] = []
> tl (h :: t) = t

> test_hd1 : hd 0 [1,2,3] = 1
> test_hd1 = Refl

> test_hd2 : hd 0 [] = 0
> test_hd2 = Refl

> test_tl : tl [1,2,3] = [2,3]
> test_tl = Refl

=== Exercises

==== Exercise: 2 stars, recommended (list_funs)

Complete the definitions of \idr{nonzeros}, \idr{oddmembers} and
\idr{countoddmembers} below. Have a look at the tests to understand what these
functions should do.

> nonzeros : (l : NatList) -> NatList
> nonzeros l = ?nonzeros_rhs

> test_nonzeros : nonzeros [0,1,0,2,3,0,0] = [1,2,3]
> test_nonzeros = ?test_nonzeros_rhs

> oddmembers : (l : NatList) -> NatList
> oddmembers l = ?oddmembers_rhs

> test_oddmembers : oddmembers [0,1,0,2,3,0,0] = [1,3]
> test_oddmembers = ?test_oddmembers_rhs

> countoddmembers : (l : NatList) -> Nat
> countoddmembers l = ?countoddmembers_rhs

> test_countoddmembers1 : countoddmembers [1,0,3,1,4,5] = 4
> test_countoddmembers1 = ?test_countoddmembers1_rhs

$\square$

==== Exercise: 3 stars, advanced (alternate)

Complete the definition of \idr{alternate}, which "zips up" two lists into one,
alternating between elements taken from the first list and elements from the
second. See the tests below for more specific examples.

Note: one natural and elegant way of writing \idr{alternate} will fail to
satisfy Idris's requirement that all function definitions be "obviously
terminating." If you find yourself in this rut, look for a slightly more verbose
solution that considers elements of both lists at the same time. (One possible
solution requires defining a new kind of pairs, but this is not the only way.)

> alternate : (l1, l2 : NatList) -> NatList
> alternate l1 l2 = ?alternate_rhs

> test_alternate1 : alternate [1,2,3] [4,5,6] =
>                             [1,4,2,5,3,6]
> test_alternate1 = ?test_alternate1_rhs

> test_alternate2 : alternate [1] [4,5,6] = [1,4,5,6]
> test_alternate2 = ?test_alternate2_rhs

> test_alternate3 : alternate [1,2,3] [4] = [1,4,2,3]
> test_alternate3 = ?test_alternate3_rhs

> test_alternate4 : alternate [] [20,30] = [20,30]
> test_alternate4 = ?test_alternate4_rhs

$\square$

=== Bags via Lists

A \idr{Bag} (or \idr{Multiset}) is like a set, except that each element can
appear multiple times rather than just once. One possible implementation is to
represent a bag of numbers as a list.

> Bag : Type
> Bag = NatList

==== Exercise: 3 stars, recommended (bag_functions)

Complete the following definitions for the functions \idr{count}, \idr{sum},
\idr{add}, and \idr{member} for bags.

> count : (v : Nat) -> (s : Bag) -> Nat
> count v s = ?count_rhs

All these proofs can be done just by \idr{Refl}.

> test_count1 : count 1 [1,2,3,1,4,1] = 3
> test_count1 = ?test_count1_rhs

> test_count2 : count 6 [1,2,3,1,4,1] = 0
> test_count2 = ?test_count2_rhs

Multiset \idr{sum} is similar to set \idr{union}: \idr{sum a b} contains all the
elements of \idr{a} and of \idr{b}. (Mathematicians usually define union on
multisets a little bit differently, which is why we don't use that name for this
operation.)

\todo[inline]{How to forbid recursion here? Edit}

For \idr{sum} we're giving you a header that does not give explicit names to the
arguments. Moreover, it uses the keyword Definition instead of Fixpoint, so
even if you had names for the arguments, you wouldn't be able to process them
recursively. The point of stating the question this way is to encourage you to
think about whether sum can be implemented in another way -- perhaps by using
functions that have already been defined.

> sum : Bag -> Bag -> Bag
> sum x y = ?sum_rhs

> test_sum1 : count 1 (sum [1,2,3] [1,4,1]) = 3
> test_sum1 = ?test_sum1_rhs

> add : (v : Nat) -> (s : Bag) -> Bag
> add v s = ?add_rhs

> test_add1 : count 1 (add 1 [1,4,1]) = 3
> test_add1 = ?test_add1_rhs

> test_add2 : count 5 (add 1 [1,4,1]) = 0
> test_add2 = ?test_add2_rhs

> member : (v : Nat) -> (s : Bag) -> Bool
> member v s = ?member_rhs

> test_member1 : member 1 [1,4,1] = True
> test_member1 = ?test_member1_rhs

> test_member2 : member 2 [1,4,1] = False
> test_member2 = ?test_member2_rhs

$\square$

==== Exercise: 3 stars, optional (bag_more_functions)

Here are some more bag functions for you to practice with.

When \idr{remove_one} is applied to a bag without the number to remove, it
should return the same bag unchanged.

> remove_one : (v : Nat) -> (s : Bag) -> Bag
> remove_one v s = ?remove_one_rhs

> test_remove_one1 : count 5 (remove_one 5 [2,1,5,4,1]) = 0
> test_remove_one1 = ?test_remove_one1_rhs

> test_remove_one2 : count 5 (remove_one 5 [2,1,4,1]) = 0
> test_remove_one2 = ?test_remove_one2_rhs

> test_remove_one3 : count 4 (remove_one 5 [2,1,5,4,1,4]) = 2
> test_remove_one3 = ?test_remove_one3_rhs

> test_remove_one4 : count 5 (remove_one 5 [2,1,5,4,5,1,4]) = 1
> test_remove_one4 = ?test_remove_one4_rhs

> remove_all : (v : Nat) -> (s : Bag) -> Bag
> remove_all v s = ?remove_all_rhs

> test_remove_all1 : count 5 (remove_all 5 [2,1,5,4,1]) = 0
> test_remove_all1 = ?test_remove_all1_rhs

> test_remove_all2 : count 5 (remove_all 5 [2,1,4,1]) = 0
> test_remove_all2 = ?test_remove_all2_rhs

> test_remove_all3 : count 4 (remove_all 5 [2,1,5,4,1,4]) = 2
> test_remove_all3 = ?test_remove_all3_rhs

> test_remove_all4 : count 5
>                    (remove_all 5 [2,1,5,4,5,1,4,5,1,4]) = 0
> test_remove_all4 = ?test_remove_all4_rhs

> subset : (s1 : Bag) -> (s2 : Bag) -> Bool
> subset s1 s2 = ?subset_rhs

> test_subset1 : subset [1,2] [2,1,4,1] = True
> test_subset1 = ?test_subset1_rhs

> test_subset2 : subset [1,2,2] [2,1,4,1] = False
> test_subset2 = ?test_subset2_rhs

$\square$

==== Exercise: 3 stars, recommended (bag_theorem)

Write down an interesting theorem \idr{bag_theorem} about bags involving the
functions \idr{count} and \idr{add}, and prove it. Note that, since this problem
is somewhat open-ended, it's possible that you may come up with a theorem which
is true, but whose proof requires techniques you haven't learned yet. Feel free
to ask for help if you get stuck!

> bag_theorem : ?bag_theorem

$\square$

== Reasoning About Lists

As with numbers, simple facts about list-processing functions can sometimes be
proved entirely by simplification. For example, the simplification performed by
\idr{Refl} is enough for this theorem...

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

... because the \idr{[]} is substituted into the "scrutinee" (the value being
"scrutinized" by the match) in the definition of \idr{app}, allowing the match
itself to be simplified.

Also, as with numbers, it is sometimes helpful to perform case analysis on the
possible shapes (empty or non-empty) of an unknown list.

> tl_length_pred : (l : NatList) -> pred (length l) = length (tl l)
> tl_length_pred [] = Refl
> tl_length_pred (n::l') = Refl

Here, the \idr{Nil} case works because we've chosen to define \idr{tl Nil =
Nil}. Notice that the case for \idr{Cons} introduces two names, \idr{n} and
\idr{l'}, corresponding to the fact that the \idr{Cons} constructor for lists
takes two arguments (the head and tail of the list it is constructing).

Usually, though, interesting theorems about lists require induction for their
proofs.

==== Micro-Sermon

Simply reading example proof scripts will not get you very far! It is important
to work through the details of each one, using Idris and thinking about what
each step achieves. Otherwise it is more or less guaranteed that the exercises
will make no sense when you get to them. 'Nuff said.

=== Induction on Lists

Proofs by induction over datatypes like \idr{NatList} are a little less familiar
than standard natural number induction, but the idea is equally simple. Each
\idr{data} declaration defines a set of data values that can be built up using
the declared constructors: a boolean can be either \idr{True} or \idr{False}; a
number can be either \idr{Z} or \idr{S} applied to another number; a list can be
either \idr{Nil} or \idr{Cons} applied to a number and a list.

Moreover, applications of the declared constructors to one another are the
_only_ possible shapes that elements of an inductively defined set can have, and
this fact directly gives rise to a way of reasoning about inductively defined
sets: a number is either \idr{Z} or else it is \idr{S} applied to some _smaller_
number; a list is either \idr{Nil} or else it is \idr{Cons} applied to some
number and some _smaller_ list; etc. So, if we have in mind some proposition
\idr{p} that mentions a list \idr{l} and we want to argue that \idr{p} holds for
_all_ lists, we can reason as follows:

  - First, show that \idr{p} is true of \idr{l} when \idr{l} is \idr{Nil}.

  - Then show that \idr{P} is true of \idr{l} when \idr{l} is \idr{Cons n l'}
    for some number \idr{n} and some smaller list \idr{l'}, assuming that
    \idr{p} is true for \idr{l'}.

Since larger lists can only be built up from smaller ones, eventually reaching
\idr{Nil}, these two arguments together establish the truth of \idr{p} for all
lists \idr{l}. Here's a concrete example:

> app_assoc : (l1, l2, l3 : NatList) -> ((l1 ++ l2) ++ l3) = (l1 ++ (l2 ++ l3))
> app_assoc [] l2 l3 = Refl
> app_assoc (n::l1') l2 l3 =
>   let inductiveHypothesis = app_assoc l1' l2 l3 in
>     rewrite inductiveHypothesis in Refl

\todo[inline]{Edit}

Notice that, as when doing induction on natural numbers, the as ... clause
provided to the induction tactic gives a name to the induction hypothesis
corresponding to the smaller list l1' in the cons case. Once again, this Coq
proof is not especially illuminating as a static written document -- it is easy
to see what's going on if you are reading the proof in an interactive Coq
session and you can see the current goal and context at each point, but this
state is not visible in the written-down parts of the Coq proof. So a
natural-language proof -- one written for human readers -- will need to include
more explicit signposts; in particular, it will help the reader stay oriented if
we remind them exactly what the induction hypothesis is in the second case.

For comparison, here is an informal proof of the same theorem.

_Theorem_: For all lists \idr{l1}, \idr{l2}, and \idr{l3},

           \idr{(l1 ++ l2) ++ l3 = l1 ++ (l2 ++l3)}.

_Proof_: By induction on \idr{l1}.

  - First, suppose \idr{l1 = []}. We must show

    \idr{([] ++ l2) ++ l3 = [] ++ (l2 ++ l3)},

    which follows directly from the definition of \idr{++}.

  - Next, suppose \idr{l1 = n :: l1'}, with

    \idr{(l1' ++ l2) ++ l3 = l1' ++ (l2 ++ l3)}

    (the induction hypothesis). We must show

    \idr{((n :: l1') ++ l2) ++ l3 = (n :: l1') ++ (l2 ++ l3)}.

    By the definition of \idr{++}, this follows from

    \idr{n :: ((l1' ++ l2) ++ l 3) = n :: (l1' ++ (l2 ++ l3))},

    which is immediate from the induction hypothesis. $\square$

==== Reversing a List

For a slightly more involved example of inductive proof over lists, suppose we
use \idr{app} to define a list-reversing function \idr{rev}:

> rev : (l : NatList) -> NatList
> rev Nil = Nil
> rev (h :: t) = (rev t) ++ [h]

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

> test_rev2 : rev Nil = Nil
> test_rev2 = Refl

==== Properties of rev

Now let's prove some theorems about our newly defined \idr{rev}. For something a
bit more challenging than what we've seen, let's prove that reversing a list
does not change its length. Our first attempt gets stuck in the successor
case...

```idris
rev_length_firsttry : (l : NatList) -> length (rev l) = length l
rev_length_firsttry Nil = Refl
rev_length_firsttry (n :: l') =
-- Now we seem to be stuck: the goal is an equality involving `++`, but we don't
-- have any useful equations in either the immediate context or in the global
-- environment! We can make a little progress by using the IH to rewrite the
-- goal...
  let inductiveHypothesis = rev_length_firsttry l' in
    rewrite inductiveHypothesis in
-- ... but now we can't go any further.
      Refl
```

So let's take the equation relating \idr{++} and \idr{length} that would have
enabled us to make progress and prove it as a separate lemma.

> app_length : (l1, l2 : NatList) ->
>               length (l1 ++ l2) = (length l1) + (length l2)
> app_length Nil l2 = Refl
> app_length (n :: l1') l2 =
>   let inductiveHypothesis = app_length l1' l2 in
>     rewrite inductiveHypothesis in
>       Refl

Note that, to make the lemma as general as possible, we quantify over _all_
\idr{NatList}s, not just those that result from an application of \idr{rev}.
This should seem natural, because the truth of the goal clearly doesn't depend
on the list having been reversed. Moreover, it is easier to prove the more
general property.

Now we can complete the original proof.

> rev_length : (l : NatList) -> length (rev l) = length l
> rev_length Nil = Refl
> rev_length (n :: l') =
>   rewrite app_length (rev l') [n] in
> -- Prelude's version of `Induction.plus_comm`
>     rewrite plusCommutative (length (rev l')) 1 in
>       let inductiveHypothesis = rev_length l' in
>         rewrite inductiveHypothesis in Refl

For comparison, here are informal proofs of these two theorems:

_Theorem_: For all lists \idr{l1} and \idr{l2},

           \idr{length (l1 ++ l2) = length l1 + length l2}.

_Proof_: By induction on \idr{l1}.

  - First, suppose \idr{l1 = []}. We must show

    \idr{length ([] ++ l2) = length [] + length l2},

    which follows directly from the definitions of \idr{length} and \idr{++}.

  - Next, suppose \idr{l1 = n :: l1'}, with

    \idr{length (l1' ++ l2) = length l1' + length l2}.

    We must show

    \idr{length ((n :: l1') ++ l2) = length (n :: l1') + length l2)}.

    This follows directly from the definitions of \idr{length} and \idr{++}
    together with the induction hypothesis. $\square$

_Theorem_: For all lists \idr{l}, \idr{length (rev l) = length l}.

_Proof_: By induction on \idr{l}.

  - First, suppose \idr{l = []}. We must show

    \idr{length (rev []) = length []},

    which follows directly from the definitions of \idr{length} and \idr{rev}.

  - Next, suppose l = n :: l' , with

    \idr{length (rev l') = length l'}.

    We must show

    \idr{length (rev (n :: l')) = length (n :: l')}.

    By the definition of \idr{rev}, this follows from

    \idr{length ((rev l') ++ [n]) = S (length l')}

    which, by the previous lemma, is the same as

    \idr{length (rev l') + length [n] = S (length l')}.

    This follows directly from the induction hypothesis and the definition of
    \idr{length}. $\square$

The style of these proofs is rather longwinded and pedantic. After the first
few, we might find it easier to follow proofs that give fewer details (which can
easily work out in our own minds or on scratch paper if necessary) and just
highlight the non-obvious steps. In this more compressed style, the above proof
might look like this:

_Theorem_: For all lists \idr{l}, \idr{length (rev l) = length l}.

_Proof_: First, observe that length \idr{(l ++ [n]) = S (length l)} for any
\idr{l} (this follows by a straightforward induction on \idr{l}). The main
property again follows by induction on \idr{l}, using the observation together
with the induction hypothesis in the case where \idr{l = n' :: l'}. $\square$

Which style is preferable in a given situation depends on the sophistication of
the expected audience and how similar the proof at hand is to ones that the
audience will already be familiar with. The more pedantic style is a good
default for our present purposes.

=== Search

\ \todo[inline]{Edit, mention \idr{:s} and \idr{:apropos}?}

We've seen that proofs can make use of other theorems we've already proved,
e.g., using \idr{rewrite}. But in order to refer to a theorem, we need to know
its name! Indeed, it is often hard even to remember what theorems have been
proven, much less what they are called.

Coq's `Search` command is quite helpful with this. Typing `Search foo` will
cause Coq to display a list of all theorems involving `foo`. For example, try
uncommenting the following line to see a list of theorems that we have proved
about `rev`:

```coq
(* Search rev. *)
```

Keep `Search` in mind as you do the following exercises and throughout the rest
of the book; it can save you a lot of time!

If you are using ProofGeneral, you can run `Search` with `C-c C-a C-a`. Pasting
its response into your buffer can be accomplished with `C-c C-;`.

=== List Exercises, Part 1

==== Exercise: 3 stars (list_exercises)

More practice with lists:

> app_nil_r : (l : NatList) -> (l ++ []) = l
> app_nil_r l = ?app_nil_r_rhs

> rev_app_distr : (l1, l2 : NatList) -> rev (l1 ++ l2) = (rev l2) ++ (rev l1)
> rev_app_distr l1 l2 = ?rev_app_distr_rhs

> rev_involutive : (l : NatList) -> rev (rev l) = l
> rev_involutive l = ?rev_involutive_rhs

There is a short solution to the next one. If you find yourself getting tangled
up, step back and try to look for a simpler way.

> app_assoc4 : (l1, l2, l3, l4 : NatList) ->
>              (l1 ++ (l2 ++ (l3 ++ l4))) = ((l1 ++ l2) ++ l3) ++ l4
> app_assoc4 l1 l2 l3 l4 = ?app_assoc4_rhs

An exercise about your implementation of \idr{nonzeros}:

> nonzeros_app : (l1, l2 : NatList) ->
>                 nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2)
> nonzeros_app l1 l2 = ?nonzeros_app_rhs

$\square$

==== Exercise: 2 stars (beq_NatList)

Fill in the definition of \idr{beq_NatList}, which compares lists of numbers for
equality. Prove that \idr{beq_NatList l l} yields \idr{True} for every list
\idr{l}.

> beq_NatList : (l1, l2 : NatList) -> Bool
> beq_NatList l1 l2 = ?beq_NatList_rhs

> test_beq_NatList1 : beq_NatList Nil Nil = True
> test_beq_NatList1 = ?test_beq_NatList1_rhs

> test_beq_NatList2 : beq_NatList [1,2,3] [1,2,3] = True
> test_beq_NatList2 = ?test_beq_NatList2_rhs

> test_beq_NatList3 : beq_NatList [1,2,3] [1,2,4] = False
> test_beq_NatList3 = ?test_beq_NatList3_rhs

> beq_NatList_refl : (l : NatList) -> True = beq_NatList l l
> beq_NatList_refl l = ?beq_NatList_refl_rhs

$\square$

=== List Exercises, Part 2

==== Exercise: 3 stars, advanced (bag_proofs)

Here are a couple of little theorems to prove about your definitions about bags
above.

> count_member_nonzero : (s : Bag) -> lte 1 (count 1 (1 :: s)) = True
> count_member_nonzero s = ?count_member_nonzero_rhs

The following lemma about \idr{lte} might help you in the next proof.

> ble_n_Sn : (n : Nat) -> lte n (S n) = True
> ble_n_Sn Z = Refl
> ble_n_Sn (S k) =
>   let inductiveHypothesis = ble_n_Sn k in
>     rewrite inductiveHypothesis in Refl

> remove_decreases_count : (s : Bag) ->
>                          lte (count 0 (remove_one 0 s)) (count 0 s) = True
> remove_decreases_count s = ?remove_decreases_count_rhs

$\square$

==== Exercise: 3 stars, optional (bag_count_sum)

Write down an interesting theorem \idr{bag_count_sum} about bags involving the
functions \idr{count} and \idr{sum}, and prove it. (You may find that the
difficulty of the proof depends on how you defined \idr{count}!)

> bag_count_sum : ?bag_count_sum

$\square$

==== Exercise: 4 stars, advanced (rev_injective)

Prove that the \idr{rev} function is injective -- that is,

> rev_injective : (l1, l2 : NatList) -> rev l1 = rev l2 -> l1 = l2
> rev_injective l1 l2 prf = ?rev_injective_rhs

(There is a hard way and an easy way to do this.)

$\square$

== Options

Suppose we want to write a function that returns the \idr{n}th element of some
list. If we give it type \idr{Nat -> NatList -> Nat}, then we'll have to choose
some number to return when the list is too short...

> nth_bad : (l : NatList) -> (n : Nat) -> Nat
> nth_bad Nil n = 42 -- arbitrary!
> nth_bad (a :: l') n = case n == 0 of
>                         True => a
>                         False => nth_bad l' (pred n)

This solution is not so good: If \idr{nth_bad} returns \idr{42}, we can't tell
whether that value actually appears on the input without further processing. A
better alternative is to change the return type of \idr{nth_bad} to include an
error value as a possible outcome. We call this type \idr{NatOption}.

> data NatOption : Type where
>   Some : Nat -> NatOption
>   None : NatOption

We can then change the above definition of \idr{nth_bad} to return \idr{None}
when the list is too short and \idr{Some a} when the list has enough members and
\idr{a} appears at position \idr{n}. We call this new function \idr{nth_error}
to indicate that it may result in an error.

> nth_error : (l : NatList) -> (n : Nat) -> NatOption
> nth_error Nil n = None
> nth_error (a :: l') n = case n == 0 of
>                           True => Some a
>                           False => nth_error l' (pred n)

> test_nth_error1 : nth_error [4,5,6,7] 0 = Some 4
> test_nth_error1 = Refl

> test_nth_error2 : nth_error [4,5,6,7] 3 = Some 7
> test_nth_error2 = Refl

> test_nth_error3 : nth_error [4,5,6,7] 9 = None
> test_nth_error3 = Refl

This example is also an opportunity to introduce one more small feature of Idris
programming language: conditional expressions...

> nth_error' : (l : NatList) -> (n : Nat) -> NatOption
> nth_error' Nil n = None
> nth_error' (a :: l') n = if n == 0
>                            then Some a
>                            else nth_error' l' (pred n)

\todo[inline]{Edit or remove this paragraph, doesn't seem to hold in Idris}

Coq's conditionals are exactly like those found in any other language, with one
small generalization. Since the boolean type is not built in, Coq actually
supports conditional expressions over any inductively defined type with exactly
two constructors. The guard is considered true if it evaluates to the first
constructor in the Inductive definition and false if it evaluates to the second.

The function below pulls the \idr{Nat} out of a \idr{NatOption}, returning a
supplied default in the \idr{None} case.

> option_elim : (d : Nat) -> (o : NatOption) -> Nat
> option_elim d (Some k) = k
> option_elim d None = d

==== Exercise: 2 stars (hd_error)

Using the same idea, fix the \idr{hd} function from earlier so we don't have to
pass a default element for the \idr{Nil} case.

> hd_error : (l : NatList) -> NatOption
> hd_error l = ?hd_error_rhs

> test_hd_error1 : hd_error [] = None
> test_hd_error1 = ?test_hd_error1_rhs

> test_hd_error2 : hd_error [1] = Some 1
> test_hd_error2 = ?test_hd_error2_rhs

> test_hd_error3 : hd_error [5,6] = Some 5
> test_hd_error3 = ?test_hd_error3_rhs

$\square$

==== Exercise: 1 star, optional (option_elim_hd)

This exercise relates your new \idr{hd_error} to the old \idr{hd}.

> option_elim_hd : (l : NatList) -> (default : Nat) ->
>                  hd default l = option_elim default (hd_error l)
> option_elim_hd l default = ?option_elim_hd_rhs

$\square$

== Partial Maps

As a final illustration of how data structures can be defined in Idris, here is
a simple _partial map_ data type, analogous to the map or dictionary data
structures found in most programming languages.

First, we define a new inductive datatype \idr{Id} to serve as the "keys" of our
partial maps.

> data Id : Type where
>   MkId : Nat -> Id

Internally, an \idr{Id} is just a number. Introducing a separate type by
wrapping each \idr{Nat} with the tag \idr{MkId} makes definitions more readable
and gives us the flexibility to change representations later if we wish.

We'll also need an equality test for \idr{Id}s:

> beq_id : (x1, x2 : Id) -> Bool
> beq_id (MkId n1) (MkId n2) = n1 == n2

==== Exercise: 1 star (beq_id_refl)

> beq_id_refl : (x : Id) -> True = beq_id x x
> beq_id_refl x = ?beq_id_refl_rhs

$\square$

Now we define the type of partial maps:

> namespace PartialMap

>   data PartialMap : Type where
>     Empty : PartialMap
>     Record : Id -> Nat -> PartialMap -> PartialMap

This declaration can be read: "There are two ways to construct a
\idr{PartialMap}: either using the constructor \idr{Empty} to represent an empty
partial map, or by applying the constructor \idr{Record} to a key, a value, and
an existing \idr{PartialMap} to construct a \idr{PartialMap} with an additional
key-to-value mapping."

The \idr{update} function overrides the entry for a given key in a partial map
(or adds a new entry if the given key is not already present).

>   update : (d : PartialMap) -> (x : Id) -> (value : Nat) -> PartialMap
>   update d x value = Record x value d

Last, the \idr{find} function searches a \idr{PartialMap} for a given key. It
returns \idr{None} if the key was not found and \idr{Some val} if the key was
associated with \idr{val}. If the same key is mapped to multiple values,
\idr{find} will return the first one it encounters.

>   find : (x : Id) -> (d : PartialMap) -> NatOption
>   find x Empty = None
>   find x (Record y v d') = if beq_id x y
>                              then Some v
>                              else find x d'

==== Exercise: 1 star (update_eq)

>   update_eq : (d : PartialMap) -> (x : Id) -> (v : Nat) ->
>               find x (update d x v) = Some v
>   update_eq d x v = ?update_eq_rhs

$\square$

==== Exercise: 1 star (update_neq)

>   update_neq : (d : PartialMap) -> (x, y : Id) -> (o : Nat) ->
>                 beq_id x y = False ->
>                 find x (update d y o) = find x d
>   update_neq d x y o prf = ?update_neq_rhs

$\square$

==== Exercise: 2 stars (baz_num_elts)

Consider the following inductive definition:

> data Baz : Type where
>   Baz1 : Baz -> Baz
>   Baz2 : Baz -> Bool -> Baz

How _many_ elements does the type \idr{Baz} have? (Answer in English or the
natural language of your choice.)

$\square$


module BoundedNat
import Data.Fin
import NatHelpers
-- Bounded Nats, Nats which are LTE than the upper bound

%default total

public export
data BoundedNat : (bound : Nat) -> Type where
  Val : (n : Nat) -> (ok : LTE n bound) -> BoundedNat bound

export
MkUpperBound : (b : Nat) -> BoundedNat b
MkUpperBound Z = Val Z LTEZero
MkUpperBound (S k) = Val (S k) (LTESucc lteRefl)

export
weakenBound : BoundedNat b -> BoundedNat (S b)
weakenBound (Val n ok) = Val n (lteRightSucc ok)

export
weakenBoundN : (n : Nat) -> BoundedNat b -> BoundedNat (b + n)
weakenBoundN k (Val n ok) = Val n (lteRightPlus ok)

||| Add a nat to a boundednat, either the sum it out of bound and the excess is returned as Left. Or the new bounded value is returned as right
export boundedAdd : BoundedNat b -> Nat -> Either Nat (BoundedNat b)
boundedAdd bounded Z = Right bounded
boundedAdd bounded (S k) {b = Z} = Left (S k)
boundedAdd (Val n ok) (S j) {b = (S k)} with (isLTE n k)
  boundedAdd (Val n ok) (S j) {b = (S k)} | (Yes prf) = let p = LTESucc prf in
                                                            boundedAdd (Val (S n) p) j
  boundedAdd (Val n ok) (S j) {b = (S k)} | (No contra) = Left (S j)

||| the predecessor of l in l <= r is also smaller than r
export lteLeftSucc : LTE (S j) k -> LTE j k
lteLeftSucc (LTESucc LTEZero) = LTEZero
lteLeftSucc (LTESucc (LTESucc x)) = LTESucc (lteLeftSucc (LTESucc x))

||| subtract a bounded nat by a Nat, the result is within bounds,
export subtractBounded : BoundedNat k -> Nat -> BoundedNat k
subtractBounded x Z = x
subtractBounded (Val Z ok) (S k) = Val Z ok
subtractBounded (Val (S j) ok) (S k) = subtractBounded (Val j (lteLeftSucc ok)) k

export
boundPlusRight : (value : Nat) -> BoundedNat (value + more)
boundPlusRight value = Val value (lteRightPlusNat value)

export
addBounded : BoundedNat b -> Nat -> BoundedNat b
addBounded x k with (boundedAdd x k)
  addBounded x k | (Left l) {b} = MkUpperBound b
  addBounded x k | (Right r) = r


module NatUtils

import Order

%default total
%access public export

|||Proof of the type that an implication implies its contrapositive
impliesContrapositive : (a : Type) -> (b : Type) -> (a -> b) -> (Not b) -> (Not a)
impliesContrapositive a b aImpliesb bFalse x = bFalse (aImpliesb x)

|||Proof that m = n implies f m = f n
--Taken from Lecture.intro with modifications
--Prelude.Basics.cong serves the same function, use cong instead
functionExtendsEquality : (typ : Type) -> (f : typ -> typ) -> (n : typ) -> (m : typ) -> (n = m) -> (f n = f m)
functionExtendsEquality type f m m Refl = Refl

|||More General function extending equality
total
functionExtendsEquality2 : (typ1 : Type) -> (typ2 : Type) -> (f : typ1 -> typ2) -> (n : typ1) -> (m : typ1) -> (n = m) -> (f n = f m)
functionExtendsEquality2 typ1 typ2 f m m Refl = Refl

|||An injective predecessor "function"
predInjective : (n : Nat) -> (Not (n = Z)) -> (k ** (S k) = n)
predInjective Z proofNotZ = void (proofNotZ Refl)
predInjective (S k) _ = (k ** Refl)

|||Proof that Z is not equal to successor of any natural number
ZIsNotS : {n : Nat} -> (Not (Z = S n))
ZIsNotS {n} proofEq = SIsNotZ (sym proofEq)

|||difference of Nats, taken from Lecture.intro
sub : (a : Nat) -> (b : Nat) -> (LTE b a) -> Nat
sub a Z LTEZero = a
sub (S a) (S b) (LTESucc proofLTE) = sub a b proofLTE

|||Proof that the sum is greater than its parts
partsLTEsum : (a : Nat) -> (b : Nat) -> (LTE a (a + b), LTE b (a + b))
partsLTEsum Z b = (LTEZero, lteRefl)
partsLTEsum (S n) b = (LTESucc (fst (partsLTEsum n b)), lteSuccRight(snd (partsLTEsum n b)))

|||Proof that S a = S b implies a = b
--Same as succInjective, but implicit
predEqual : {a : Nat} -> {b : Nat} -> (S a = S b) -> (a = b)
predEqual Refl = Refl

|||Proof that a != b implies (S a) != (S b)
notEqualSucc : {a : Nat} -> {b : Nat} -> (Not (a = b)) -> (Not ((S a) = (S b)))
notEqualSucc {a} {b} proofNotEq proofEq = proofNotEq (predEqual proofEq)

|||Proof that (S a) != (S b) implies a != b
notEqualPred : {a : Nat} -> {b : Nat} -> (Not ((S a) = (S b))) -> (Not (a = b))
notEqualPred {a} {b} proofNotEq proofEq = proofNotEq (cong proofEq)

|||Proof that (a + b) = 0 implies a = 0 and b = 0
sumZeroImpliesZero : {a : Nat} -> {b : Nat} -> (a + b = Z) -> (a = Z, b = Z)
sumZeroImpliesZero {a = Z} {b = Z} Refl = (Refl, Refl)
sumZeroImpliesZero {a = Z} {b = S k} proofEq = void (SIsNotZ proofEq)
sumZeroImpliesZero {a = S k} {b} proofEq = void (SIsNotZ proofEq)

|||Proof that (a * b) = 0 implies a = 0 or b = 0
multZeroImpliesZero : {a : Nat} -> {b : Nat} -> (a * b = Z) -> Either (a = Z) (b = Z)
multZeroImpliesZero {a = Z} {b} proofZ = Left Refl
multZeroImpliesZero {a = S k} {b = Z} proofZ = Right Refl
multZeroImpliesZero {a = S k} {b = S l} proofZ = void (SIsNotZ proofZ)

|||Proof that a + k = b and k != 0 implies a != b
nonZeroSumNotEqual : {a : Nat} -> {b : Nat} -> {k : Nat} -> (a + k = b) -> (Not (k = Z)) -> (Not (a = b))
nonZeroSumNotEqual {a} {b} {k} proofEq proofNotZ proofaEqb = proofNotZ kEqZ where
	kEqZ = (plusLeftCancel a k Z aPluskEqaPlusZ) where
		aPluskEqaPlusZ = (trans aPluskPlEqbPlusZ (sym ((cong {f = (\n => (n + Z))}) proofaEqb))) where
			aPluskPlEqbPlusZ = rewrite (plusZeroRightNeutral b) in proofEq

|||Proof that a + k = b and a != b implies k != 0
nonEqualSumNotZero : {a : Nat} -> {b : Nat} -> {k : Nat} -> (a + k = b) -> (Not (a = b)) -> (Not (k = Z))
nonEqualSumNotZero {a} {b} {k} proofEq proofaNotEqb proofkEqZ =
	proofaNotEqb proofaEqb where
		proofaEqb = rewrite (plusCommutative Z a) in
				  rewrite (sym proofkEqZ) in
				  proofEq

|||Proof that a != 0 implies a + b != 0
nonZeroSumNotZeroLeft :  {a : Nat} -> (b : Nat) -> (Not (a = Z)) -> Not (a + b = Z)
nonZeroSumNotZeroLeft {a} b proofNotZero proofZero = proofNotZero (fst (sumZeroImpliesZero proofZero))

|||Proof that b != 0 implies a + b != 0
nonZeroSumNotZeroRight :  {a : Nat} -> (b : Nat) -> (Not (b = Z)) -> Not (a + b = Z)
nonZeroSumNotZeroRight {a} b proofNotZero proofZero = proofNotZero (snd (sumZeroImpliesZero proofZero))

|||Proof that a != 0 and b != 0 implies a * b ! = 0
nonZeroMultNotZero : {a : Nat} -> {b : Nat} ->
				 (Not (a = Z)) -> (Not (b = Z)) -> (Not (a * b = Z))
nonZeroMultNotZero {a} {b} aNotZ bNotZ proofZero =
	case (multZeroImpliesZero proofZero) of
		(Left aEqZ) => aNotZ aEqZ
		(Right bEqZ) => bNotZ bEqZ

|||Proof that (S a) + b = a + (S b)
plusSymmetricInS : {a : Nat} -> {b : Nat} -> ((S a) + b = a + (S b))
plusSymmetricInS {a = Z} {b} = Refl
plusSymmetricInS {a = S k} {b} = cong (plusSymmetricInS {a = k} {b})

|||Proof that a = b implies c * a = c * b
multConstantLeft : {a : Nat} -> {b : Nat} -> (c : Nat) -> (a = b) -> ((c * a) = (c * b))
multConstantLeft {a} {b} Z _ = Refl
multConstantLeft {a} {b} (S k) proofEq =
	trans (cong {f = (\n => n + (k * a))} proofEq) (cong {f = (\n => b + n)} inductiveProofEq) where
		inductiveProofEq = multConstantLeft {a} {b} k proofEq

|||Proof that a = b implies a * c = b * c
multConstantRight : {a : Nat} -> {b : Nat} -> (c : Nat) -> (a = b) -> ((a * c) = (b * c))
multConstantRight {a} {b} c proofEq = rewrite (multCommutative a c) in
							   rewrite (multCommutative b c) in
							   multConstantLeft c proofEq

|||Proof that c * a != c * b implies a != b
multConstantLeftNot : {a : Nat} -> {b : Nat} -> {c : Nat} -> (Not ((c * a) = (c * b))) -> (Not (a = b))
multConstantLeftNot {a} {b} {c} proofNotEq proofEq = void (proofNotEq (cong {f = (\n => c * n)} proofEq))

|||Proof that a * c != b * c implies a != b
multConstantRightNot : {a : Nat} -> {b : Nat} -> {c : Nat} -> (Not ((a * c) = (b * c))) -> (Not (a = b))
multConstantRightNot {a} {b} {c} proofNotEq proofEq = void (proofNotEq (cong {f = (\n => n * c)} proofEq))

|||Proof that a * c = b * c implies a = b
multRightCancel : (left1 : Nat) -> (left2 : Nat) -> (right : Nat) ->
				(Not (right = Z)) -> (left1 * right = left2 * right) -> (left1 = left2)
multRightCancel left1 left2 Z rightnotzero prf = void (rightnotzero Refl)
multRightCancel Z Z (S k) rightnotzero prf = Refl
multRightCancel Z (S _) (S _) _ proofEq = void (ZIsNotS proofEq)
multRightCancel (S _) Z (S _) _ proofEq = void (SIsNotZ proofEq)
multRightCancel (S j) (S i) (S k) rightnotzero prf = cong (multRightCancel j i (S k) rightnotzero (plusLeftCancel (S k) (j * (S k)) (i * (S k))  prf))

|||Proof that c * a = c * b implies a = b
multLeftCancel : (left : Nat) -> (right1 : Nat) -> (right2 : Nat) ->
			  (Not (left = Z)) -> (left * right1 = left * right2) -> (right1 = right2)
multLeftCancel c a b notZ proofEq =
	multRightCancel a b c notZ rewriteProof where
		rewriteProof = rewrite (multCommutative a c) in
					rewrite (multCommutative b c) in
					proofEq

|||Proof of distributivity
distributeProof: (a : Nat) -> (b : Nat) -> (d : Nat) -> (m : Nat) -> (n : Nat) ->
(a = m * d) -> (b = n * d) -> ((a + b) = (m + n) * d)
distributeProof a b d m n proofDividesa proofDividesb =
	rewrite (multDistributesOverPlusLeft m n d) in
		(trans (the (a + b = (m * d) + b) (v1)) v2) where
			v1 = plusConstantRight a (m * d) b proofDividesa
			v2 = plusConstantLeft b (n * d) (m * d) proofDividesb

|||Proof that n * a = a and a != 0 implies n = 1
multLeftIdIsOne : {n : Nat} -> {a : Nat} ->
			   (Not (a = Z)) -> (n * a = a) -> (n = 1)
multLeftIdIsOne {n} {a} notZ proofEq = trans (sym (multOneRightNeutral n)) (multRightCancel (n * 1) 1 a notZ (rewrite (sym (multAssociative n 1 a)) in (rewrite (multOneLeftNeutral a) in proofEq)))

|||Proof that p = a * b and a = 1 implies p = b
multOneLeftEqual : {p : Nat} -> {a : Nat} -> {b : Nat} -> (p = a * b) -> (a = 1) -> (p = b)
multOneLeftEqual {p} {a} {b} proofEq aIs1 =
	trans (trans proofEq (cong {f = (\n => n * b)} aIs1)) (multOneLeftNeutral b)

|||Proof that p = a * b and b = 1 implies p = a
multOneRightEqual : {p : Nat} -> {a : Nat} -> {b : Nat} -> (p = a * b) -> (b = 1) -> (p = a)
multOneRightEqual {p} {a} {b} proofEq bIs1 =
	rewrite (sym (multOneRightNeutral a)) in
	rewrite (sym bIs1) in
	proofEq

|||Proof that (a + k = b) and (b + l = a) implies a = b
plusAntiSymmetric : {a : Nat} -> {b : Nat} -> {k : Nat} -> {l : Nat} ->
					  (a + k = b) -> (b + l = a) -> (a = b)
plusAntiSymmetric {a} {b} {k} {l} proofEqLeft proofEqRight =
	(rewrite (sym (plusZeroRightNeutral a)) in (rewrite (sym (fst (sumZeroImpliesZero (plusLeftCancel a (k + l) Z step)))) in proofEqLeft)) where
		step = trans (rewrite (plusAssociative a k l) in (trans (cong {f = (\n => n + l)} proofEqLeft) proofEqRight)) (sym (plusZeroRightNeutral a))

|||Proof that a = r + q * b implies (n * a) = (n * r) + q * (n * b)
extendEqualMult : {a : Nat} -> {b : Nat} -> {q : Nat} -> {r : Nat} ->
			   (a = r + (q * b)) -> (n : Nat) -> ((n * a) = (n * r) + q * (n * b))
extendEqualMult {a} {b} {q} {r} proofEq n =
	rewrite (multAssociative q n b) in
	rewrite (multCommutative q n) in
	rewrite (sym (multAssociative n q b)) in
	rewrite (sym (multDistributesOverPlusRight n r (q * b))) in
	cong {f = (\l => n * l)} proofEq

||| Proof that a = c, b = d and a <= b implies c <= d
lteSubstitutes : {a : Nat} -> {b : Nat} -> {c : Nat} -> {d : Nat} ->
				(LTE a b) -> (a = c) -> (b = d) -> (LTE c d)
lteSubstitutes proofLTE Refl Refl = proofLTE

|||Proof that a < b implies a <= b
ltImpliesLTE : {a : Nat} -> {b : Nat} -> (LT a b) -> (LTE a b)
ltImpliesLTE proofLTE = lteSuccLeft proofLTE

|||Proof that a = b implies a <= b
eqImpliesLTE : {a : Nat} -> {b : Nat} -> (a = b) -> (LTE a b)
eqImpliesLTE {a = Z} {b = Z} Refl = LTEZero
eqImpliesLTE {a = S k} {b = Z} proofEq = void(SIsNotZ proofEq)
eqImpliesLTE {a = Z} {b = S l} proofEq = void(SIsNotZ (sym proofEq))
eqImpliesLTE {a = S k} {b = S l} proofEq = LTESucc (eqImpliesLTE (predEqual proofEq))

|||The theorem that (a <= b) and (b <= a) implies a = b
lteAntiSymmetric : {a : Nat} -> {b : Nat} -> (LTE a b) -> (LTE b a) -> (a = b)
lteAntiSymmetric LTEZero LTEZero = Refl
lteAntiSymmetric (LTESucc a) (LTESucc b) = cong (lteAntiSymmetric a b)

|||Proof that a < b implies S a = b or S a < b
ltImpliesEqOrLT : (a : Nat) -> (b : Nat) -> (LT a b) -> Either (S a = b) (LT (S a) b)
ltImpliesEqOrLT Z (S Z) (LTESucc LTEZero) = Left Refl
ltImpliesEqOrLT Z (S (S b)) (LTESucc LTEZero) = Right (LTESucc (LTESucc LTEZero))
ltImpliesEqOrLT (S a) (S b) proofSaLTSb =
	case (ltImpliesEqOrLT a b (fromLteSucc proofSaLTSb)) of
		(Left proofSaEqb) => Left (cong proofSaEqb)
		(Right proofSaLTb) => Right (LTESucc proofSaLTb)

|||Proof that a <= b implies a <= (c + b)
ltePlusConstant : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LTE a b) -> (LTE a (c + b))
ltePlusConstant {a} {b} c proofLTE = lteSubstitutes (lteTransitive proofLTE (lteAddRight b)) Refl (plusCommutative b c)

|||Proof that a <= b implies (c + a) <= (c + b)
ltePlusConstantLeft : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LTE a b) -> (LTE (c + a) (c + b))
ltePlusConstantLeft Z proofLTE = proofLTE
ltePlusConstantLeft (S k) proofLTE = LTESucc (ltePlusConstantLeft k proofLTE)

|||Proof that a <= b implies (a + c) <= (b + c)
ltePlusConstantRight : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LTE a b) -> (LTE (a + c) (b + c))
ltePlusConstantRight {a} {b} c proofLTE =
	rewrite (plusCommutative a c) in
	rewrite (plusCommutative b c) in
	(ltePlusConstantLeft c proofLTE)

|||Proof that (c + a) <= (c + b) implies a <= b
lteMinusConstantLeft : {a : Nat} -> {b : Nat} -> {c : Nat} -> (LTE (c + a) (c + b)) -> (LTE a b)
lteMinusConstantLeft {c = Z} proofLTE = proofLTE
lteMinusConstantLeft {c = S k} (LTESucc proofLTE) = lteMinusConstantLeft {c = k} proofLTE

|||Proof that (a + c) <= (b + c) implies a <= b
lteMinusConstantRight : {a : Nat} -> {b : Nat} -> {c : Nat} -> (LTE (a + c) (b + c)) -> (LTE a b)
lteMinusConstantRight {a} {b} {c} proofLTE =
	lteMinusConstantLeft (lteSubstitutes proofLTE (plusCommutative a c) (plusCommutative b c))

|||Proof that if a <= b, and c <= d, then (a + c) <= (b + d)
ltePlusIsLTE : {a : Nat} -> {b : Nat} -> {c : Nat} -> {d : Nat} ->
			(LTE a b) -> (LTE c d) -> (LTE (a + c) (b + d))
ltePlusIsLTE {a = a0} {b = b0} {c = c0} {d = d0} proofLeftLTE proofRightLTE =
	lteTransitive (ltePlusConstantRight {a = a0} {b = b0} c0 proofLeftLTE) (ltePlusConstantLeft {a = c0} {b = d0} b0 proofRightLTE)

|||Proof that m <= (S k) * m
lteMultLeft : (k : Nat) -> (m : Nat) -> (LTE m ((S k) * m))
lteMultLeft Z m = rewrite (multOneLeftNeutral m) in (lteRefl)
lteMultLeft (S k) m = ltePlusConstant m (lteMultLeft k m)

|||Proof that if a <= b then a < (c + b) when c is not zero
ltePlusConstantLt : (c : Nat) -> (Not (c = Z)) -> (LTE a b) -> (LT a (c + b))
ltePlusConstantLt Z cnotz prf = void (cnotz Refl)
ltePlusConstantLt (S k) cnotz LTEZero = LTESucc LTEZero
ltePlusConstantLt {a = (S j)} {b = (S i)} (S k) cnotz (LTESucc prf) =
	LTESucc (rewrite (sym (plusSuccRightSucc k i)) in (ltePlusConstantLt (S k) cnotz prf))

|||Proof that a positive number (S m) is less than (S m) multiplied by a number greater that one
ltMultPosByGt1 : (k : Nat) -> (m : Nat) -> (LT (S m) ((S (S k) * (S m))))
ltMultPosByGt1 Z m = rewrite (plusZeroRightNeutral m) in ltePlusConstantLt (S m) SIsNotZ lteRefl
ltMultPosByGt1 (S k) m = ltePlusConstantLt (S m) SIsNotZ (ltImpliesLTE (ltMultPosByGt1 k m))

|||Proof that a <= b implies (c * a) <= (c * b)
lteMultConstantLeft : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LTE a b) -> (LTE (c * a) (c * b))
lteMultConstantLeft {a} {b} Z _ = LTEZero
lteMultConstantLeft {a} {b} (S k) proofLTE =
	ltePlusIsLTE proofLTE (lteMultConstantLeft {a} {b} k proofLTE)

|||Proof that a <= b implies (a * c) <= (b * c)
lteMultConstantRight : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LTE a b) -> (LTE (a * c) (b * c))
lteMultConstantRight {a} {b} c proofLTE = rewrite (multCommutative a c) in
								  rewrite (multCommutative b c) in
								  (lteMultConstantLeft c proofLTE)

|||Proof that if a <= b, and c <= d, then (a * c) <= (b * d)
lteMultIsLTE : {a : Nat} -> {b : Nat} -> {c : Nat} -> {d : Nat} ->
			(LTE a b) -> (LTE c d) -> (LTE (a * c) (b * d))
lteMultIsLTE {a = a0} {b = b0} {c = c0} {d = d0} proofLeftLTE proofRightLTE =
	lteTransitive (lteMultConstantRight {a = a0} {b = b0} c0 proofLeftLTE) (lteMultConstantLeft {a = c0} {b = d0} b0 proofRightLTE)

|||Proof that n is not lesser than n
succNotLTEn : {n : Nat} -> (LT n n) -> Void
succNotLTEn {n = Z} proofLTE = void (succNotLTEzero proofLTE)
succNotLTEn {n = S k} (LTESucc proofLTE) = succNotLTEn {n = k} proofLTE

|||Proof that k < n implies n != 0
gtSuccImpliesNotZ : {k : Nat} -> (n : Nat) -> (LT k n) -> (Not (n = Z))
gtSuccImpliesNotZ {k} n proofLT nIsZ = succNotLTEzero (lteSubstitutes proofLT Refl nIsZ)

|||Proof that a < b implies a != b and !(b < a)
ltImpliesNotEqNotGT : {a : Nat} -> {b : Nat} -> (LT a b) -> (Not (a = b), Not (LT b a))
ltImpliesNotEqNotGT {a} {b = Z} proofLT = void (succNotLTEzero proofLT)
ltImpliesNotEqNotGT {a = Z} {b = S l} proofLT = (ZIsNotS, succNotLTEzero)
ltImpliesNotEqNotGT {a = S k} {b = S l} (LTESucc proofLT) =
	((\proofEq => inductionStep1 (predEqual proofEq)), (\proofLT => inductionStep2 (lteMinusConstantLeft {c = 1} proofLT))) where
		inductionStep1 = fst (ltImpliesNotEqNotGT {a = k} {b = l} proofLT)
		inductionStep2 = snd (ltImpliesNotEqNotGT {a = k} {b = l} proofLT)

|||Proof that a < b implies a != b
ltImpliesNotEq : {a : Nat} -> {b : Nat} -> (LT a b) -> (Not (a = b))
ltImpliesNotEq {a} {b = Z} proofLT proofEq = succNotLTEzero proofLT
ltImpliesNotEq {a = Z} {b = (S l)} proofLT proofEq = ZIsNotS proofEq
ltImpliesNotEq {a = (S k)} {b = (S l)} (LTESucc proofLT) proofEq = ltImpliesNotEq {a = k} {b = l} proofLT (predEqual proofEq)

|||Proof that a = b implies !(a < b) and !(b < a)
eqImpliesNotLTNotGT : {a : Nat} -> {b : Nat} -> (a = b) -> (Not (LT a b), Not (LT b a))
eqImpliesNotLTNotGT {a = k} {b = k} Refl = (succNotLTEn, succNotLTEn)

|||Proof that ! (a <= b) implies (b <= a)
notLTEImpliesGTE : {a : Nat} -> {b : Nat} -> (Not (LTE a b)) -> (LTE b a)
notLTEImpliesGTE {a = Z} {b} contra = void (contra (LTEZero))
notLTEImpliesGTE {a = (S k)} {b = Z} contra = LTEZero
notLTEImpliesGTE {a = (S k)} {b = (S j)} contra =
	LTESucc (notLTEImpliesGTE {a = k} {b = j} (\evidence => contra (LTESucc evidence)))

|||Proof that (a * b) = 1 implies a = 1 and b = 1
multOneImpliesOne : {a : Nat} -> {b : Nat} -> (a * b = 1) -> (a = 1, b = 1)
multOneImpliesOne {a = Z} {b} proofEq = void (ZIsNotS proofEq)
multOneImpliesOne {a} {b = Z} proofEq = void (ZIsNotS (rewrite (sym (multZeroRightZero a)) in proofEq))
multOneImpliesOne {a = S Z} {b = S Z} _ = (Refl, Refl)
multOneImpliesOne {a = (S (S k))} {b = (S l)} proofEq = void (ltImpliesNotEq (lteTransitive (LTESucc (LTESucc LTEZero)) (fst (partsLTEsum (S (S k)) (l * (S (S k)))))) (sym (rewrite (multCommutative (S l) (S (S k))) in proofEq)))
multOneImpliesOne {a = (S k)} {b = (S (S l))} proofEq = void (ltImpliesNotEq (lteTransitive (LTESucc (LTESucc LTEZero)) (fst (partsLTEsum (S (S l)) (k * (S (S l)))))) (sym proofEq))

|||Proof that (a = k * b) and (b = l * a) implies (a = b)
multAntiSymmetric : {a : Nat} -> {b : Nat} -> {k : Nat} -> {l : Nat} ->
					(a = k * b) -> (b = l * a) -> (a = b)
multAntiSymmetric {a = Z} {b} {k} {l} proofEqLeft proofEqRight = sym (rewrite (sym (multZeroRightZero l)) in proofEqRight)
multAntiSymmetric {a = (S n)} {b} {k} {l} proofEqLeft proofEqRight =
	rewrite (sym (multOneLeftNeutral b)) in
	(trans proofEqLeft (cong {f = (\k => k * b)} (fst (multOneImpliesOne (sym (multRightCancel 1 (k * l) (S n) SIsNotZ proofEq)))))) where
		proofEq = rewrite (sym (multAssociative k l (S n))) in
				rewrite (sym proofEqRight) in
				rewrite (multOneLeftNeutral (S n)) in
				proofEqLeft

|||Returns Max of two numbers with proof that it is maximum
max : (a : Nat) -> (b : Nat) -> (n : Nat ** ((LTE a n, LTE b n), Either (a=n) (b=n)))
max a b = case isLTE a b of
	(Yes prf) => (b ** ((prf, lteRefl), (Right Refl)))
	(No contra) => (a ** ((lteRefl, (notLTEImpliesGTE contra)), (Left Refl)))

|||Proof that ! ((S a) < a)
succNotLTEnum : (a : Nat) -> (LTE (S a) a) -> Void
succNotLTEnum Z LTEZero impossible
succNotLTEnum Z (LTESucc _) impossible
succNotLTEnum (S k) (LTESucc proofLTE) = succNotLTEnum k proofLTE

|||Proof that an element of LTE m n implies an lte m n = True
LTEmeanslteTrue: (m: Nat) -> (n: Nat) -> (LTE m n) -> (lte m n = True)
LTEmeanslteTrue Z n LTEZero = Refl
LTEmeanslteTrue (S left) (S right) (LTESucc x) = LTEmeanslteTrue left right x


-- Find the numbers in a list that are greater than a given number.
greater : Int -> List Int -> List Int
greater number list = filter (> number) list

-- Create data types representing even and odd numbers such that:
-- – The successor to an even number is an odd number, and
-- – The successor to an odd number is an even number.
data EvenOdd = Even Nat | Odd Nat

succ : EvenOdd -> EvenOdd
succ (Even n) = Odd (S n)
succ (Odd n)  = Even (S n)

-- Build a parameterized data type representing a binary tree.
data BinaryTree a = Leaf a | Node (BinaryTree a) (BinaryTree a)

-- Reverse the elements of a list. (Hint: You may need some helper functions.)
reverse : List a -> List a
reverse = reverse' []
  where
    reverse' : List a -> List a -> List a
    reverse' acc []      = acc
    reverse' acc (x::xs) = reverse' (x::acc) xs


module Control.Permutation.Proofs

import Control.Permutation.Mod

%access export
%default total

||| Proof that (n + 1)! >= n!
private
factorialIncr : (n : Nat) -> LTE (factorial n) (factorial (S n))
factorialIncr Z = lteRefl
factorialIncr n = lteAddRight (factorial n)

||| Proof that n! >= 1
export
factorialLTE : (n : Nat) -> LTE 1 (factorial n)
factorialLTE Z = lteRefl
factorialLTE (S k) = lteTransitive (factorialLTE k) (factorialIncr k)


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) = case checkEqNat k j of
                              Nothing => Nothing
                              (Just eq) => Just (sameS _ _ eq)

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

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

same_cons : {xs : List a} -> {ys : List a} -> xs = ys -> x ::xs = x :: ys
same_cons Refl = Refl

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

data ThreeEq : (a : Nat) -> (b : Nat) -> (c : Nat) -> Type where
  ThreeSame : (num : Nat) -> ThreeEq num num num

allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS Z Z Z (ThreeSame Z) = ThreeSame (S Z)
allSameS (S k) (S k) (S k) (ThreeSame (S k)) = ThreeSame (S (S k))

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

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

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

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

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

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

import public Specifications.Semigroup

%default total
%access public export

infixl 8 #

||| specification
isNeutralL : Binop s -> s -> Type
isNeutralL (#) e = (x : _) -> e # x = x

||| specification
isNeutralR : Binop s -> s -> Type
isNeutralR (#) e = (x : _) -> x # e = x

||| composed specification
data MonoidSpec : Binop s -> s -> Type where
  MkMonoid : isAssociative op -> isNeutralL op e -> isNeutralR op e ->
    MonoidSpec op e

||| forget
associative : MonoidSpec op _ -> isAssociative op
associative (MkMonoid g _ _) = g

||| forget
neutralL : MonoidSpec op e -> isNeutralL op e
neutralL (MkMonoid _ l _) = l

||| forget
neutralR : MonoidSpec op e -> isNeutralR op e
neutralR (MkMonoid _ _ r) = r


-- ---------------------------------------------------------- [ Predicates.idr ]
-- Module    : Predicates.idr
-- Copyright : (c) Jan de Muijnck-Hughes
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]

||| More Quantifiers for Lists, but keeping them out of the prelude so
||| need a new module name.
module Data.List.Predicates

import public Data.List

%default total
%access public export

||| Proof that an element is not in a list.
data NotElem : (elem : ty)
            -> (list : List ty)
            -> Type
  where
    NotHere  : NotElem x []
    NotThere : Eq ty
            => {x,y : ty}
            -> (prf : x /= y = True)
            -> NotElem x xs
            -> NotElem x (y::xs)

||| Proof that the given list is made of unique elements.
data AllDiff : (unique : List ty)
            -> Type
  where
    EmptyCase : AllDiff Nil
    OneCase   : AllDiff [x]
    ManyCase  : NotElem x xs -> AllDiff xs -> AllDiff (x::xs)

||| Proof that `sub_list` is an actual sub list of `list`
data SubList : (sub_list : List ty)
            -> (list     : List ty )
            -> Type
  where
    SubNil : SubList [] xs
    InList : (prf  : Elem x ys)
          -> (rest : SubList xs ys)
          -> SubList (x :: xs) ys

||| Proof that the contents of the given list of pairs originate from
||| a secondary list.
data PairsFromList : (pairs  : List (ty,ty))
                  -> (origin : List ty)
                  -> Type
  where
    NilPair : PairsFromList Nil as
    PairIn  : Elem a as
           -> Elem b as
           -> PairsFromList abs            as
           -> PairsFromList ((a,b) :: abs) as

||| Proof that the given list of paired elements originate from the
||| two given lists such that the following hold:
|||
|||    SubList (map fst pairs) as
|||
||| and
|||
|||    SubList (map snd pairs) bs
|||
data UnZipPairs : (pairs : List (ty,ty))
               -> (as    : List ty)
               -> (bs    : List ty)
               -> Type
  where
    UnZipOne  : UnZipPairs Nil as bs
    UnZipPair : (prf_a : Elem a as)
             -> (prf_b : Elem b bs)
             -> (rest  : UnZipPairs abs as bs)
             -> UnZipPairs ((a,b) :: abs) as bs

||| Proof that the given list of paired elements not only originate
||| from the given lists, but that all elements are unique.
data UZipPairsU : (pairs : List (ty,ty))
               -> (as    : List ty)
               -> (bs    : List ty)
               -> Type
  where
    ValidUSPU : (uniqueAs  : AllDiff as)
             -> (uniqueBs  : AllDiff bs)
             -> (uniqueABs : AllDiff (as ++ bs))
             -> (vswap     : UnZipPairs cs as bs)
             -> UZipPairsU cs as bs

-- --------------------------------------------------------------------- [ EOF ]


data Nat = Z | S Nat

plus : Nat -> Nat -> Nat
plus Z     y = y
plus (S k) y = S (plus k y)

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

foldl : (0 b : Nat -> Type) ->
        ({k : Nat} -> b k -> a -> b (S k)) ->
        b Z ->
        Vect n a -> b n
foldl b g z Nil = z
foldl b g z (Cons x xs) = foldl (\i => b (S i)) g (g z x) xs

reverse : Vect n a -> Vect n a
reverse
    = foldl (\m => Vect m a)
            (\rev => \x => Cons x rev) Nil

append : Vect n a -> Vect m a -> Vect (plus n m) a
append Nil ys = ys
append (Cons x xs) ys = Cons x (append xs ys)

vlength : (n : Nat) -> Vect n a -> Nat
vlength Z Nil = Z
vlength n@_ (Cons x xs) = n -- (vlength _ xs);

zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c
zipWith f Nil Nil = Nil
-- zipWith f (Cons x xs) Nil impossible
zipWith f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWith f xs ys)


module Rationals

isFactorInt : Integer -> Integer -> Type  --Needed for defining Integer division
isFactorInt m n = (k : Integer ** (m * k = n))

divides : (m: Integer) -> (n: Integer) -> (k: Integer ** (m * k = n)) -> Integer
divides m n k = (fst k)

Pair : Type
Pair = (Integer, Integer)

Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat) --Euclidean algorithm implemented by Chinmaya
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)

gcdab : Nat -> Nat -> Nat -- Produces the GCD of two numbers. This will be useful to produce the simplified form of a rational number.
gcdab b Z = b
gcdab a b = gcdab b (snd (Eucl a b))

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

make_rational : (p: Nat) -> (q: Integer) -> NotZero q -> Pair
make_rational p q x = (toIntegerNat(p), q)

InclusionMap : (n : Nat) -> Pair --Includes the naturals in Q
InclusionMap n = make_rational n 1 OneNotZero

AddRationals : (x: Pair) -> NotZero (snd x) -> (y: Pair) -> NotZero (snd y) -> Pair
AddRationals x a y b = ((fst x)*(snd y) + (snd x)*(fst y), (snd x)*(snd y))

MultiplyRationals : (x: Pair) -> NotZero (snd x) -> (y: Pair) -> NotZero (snd y) -> Pair
MultiplyRationals x a y b =((fst x)*(fst y), (snd x)*(snd y))

MultInverse : (x: Pair) -> NotZero (fst x) -> NotZero (snd x) -> Pair
MultInverse x y z = ((snd x), (fst x))

AddInverse : (x: Pair) -> NotZero (snd x) -> Pair
AddInverse x a = (-(fst x), (snd x))

Subtraction : (x: Pair) -> NotZero (snd x) -> (y: Pair) -> NotZero (snd y) -> Pair
Subtraction x a y b = AddRationals x a (AddInverse y b) b

Division : (x: Pair) -> NotZero (snd x) -> (y: Pair) -> NotZero (fst y) -> NotZero (snd y) -> Pair
Division x a y b c = MultiplyRationals x a (MultInverse y b c) b

--SimplifyRational : (x: Pair) -> NotZero (snd x) -> Pair
--SimplifyRational x a = (divides (gcdab fromIntegerNat((fst x)) fromIntegerNat((snd x))) ___ (fst x), divides (gcdab fromIntegerNat((fst x)) fromIntegerNat((snd x)) __ (snd x))

--Above, I will need to supply a proof that the GCD divides the two numbers. Then, the function defined above will produce the rational in simplified form.


module IdrisProject

||| document
export
plus_reduces : (n : Nat) -> Z + n = n
plus_reduces n = Refl

export
plus_right_id : (n : Nat) -> n + 0 = n
plus_right_id Z = Refl
plus_right_id (S n) = cong S (plus_right_id n)

export
plus_reduces_S : (n : Nat) -> (m : Nat) -> n + (S m) = S (n + m)
plus_reduces_S Z m = cong S Refl
-- cong: congruence, take `f` to show `a = b` iff `(f a) = (f b)`
plus_reduces_S (S k) m = cong S (plus_reduces_S k m)

export
plus_commutes_Z : (m : Nat) -> m = plus m Z
plus_commutes_Z 0 = Refl
plus_commutes_Z (S k) = cong S (plus_commutes_Z k)

export
plus_commutes_S : (k : Nat) -> (m : Nat) -> S (plus m k) = plus m (S k)
plus_commutes_S k 0 = Refl
plus_commutes_S k (S j) = cong S (plus_commutes_S k j)

export
plus_commutes : (n, m : Nat) -> n + m = m + n
plus_commutes Z m = (plus_commutes_Z m)
plus_commutes (S k) m = rewrite plus_commutes k m in (plus_commutes_S k m)

export
sym : forall x, y . (0 rule : x = y) -> y = x
sym Refl = Refl

export
trans : forall x, y, z . (0 l : x = y) -> (0 r : y = z) -> x = z
trans Refl Refl = Refl


---
title: Logic
subtitle: An Idris port of Coq.Init.Logic
title-meta: "Logic: An Idris port of Coq.Init.Logic"
author:
- |
  \affaddr{Eric Bailey}\
  \affaddr{https://github.com/yurrriq}\
  \email{eric@ericb.me}
author-meta: Eric Bailey
abstract: Here I present an Idris port of the [`Coq.Init.Logic`](https://coq.inria.fr/library/Coq.Init.Logic.html) module from the Coq standard library.
keywords:
- logic
- coq
- idris
pandoc-minted:
  language: idris
---

> ||| An Idris port of Coq.Init.Logic
> module Logic
>
> import Data.Bifunctor
>
> %access export

= Propositional connectives

== Unit

`()` is the always true proposition ($\top$).

```idris
%elim data Unit = MkUnit
```

== Void

`Void` is the always false proposition ($\bot$).

```idris
%elim data Void : Type where
```

== Negation

`Not a`, written `~a`, is the negation of `a`.

> syntax "~" [x] = (Not x)

```idris
Not : Type -> Type
Not a = a -> Void
```

== Conjunction

`And a b`, written `(a, b)`, is the conjunction of `a` and `b`.

`Conj p q` is a proof of `(a, b)` as soon as `p` is a proof of `a` and `q` a proof of `b`.

`proj1` and `proj2` are first and second projections of a conjunction.

> syntax "(" [a] "," [b] ")" = (And a b)
>
> ||| The conjunction of `a` and `b`.
> data And : Type -> Type -> Type where
>      Conj : a -> b -> (a, b)
>
> implementation Bifunctor And where
>     bimap f g (Conj a b) = Conj (f a) (g b)
>
> ||| First projection of a conjunction.
> proj1 : (a, b) -> a
> proj1 (Conj a _) = a
>
> ||| Second projection of a conjunction.
> proj2 : (a, b) -> b
> proj2 (Conj _ b) = b

== Disjunction

`Either a b` is the disjunction of `a` and `b`.

```idris
data Either : Type -> Type -> Type where
     Left   : a -> Either a b
     Right  : b -> Either a b
```

== Biconditional

[Proof Wiki](https://proofwiki.org/wiki/Definition:Biconditional)

 <!-- $\varphi \vdash \psi$\ -->
 <!-- $\underline{\psi \vdash \varphi}$\ -->
 <!-- $\varphi \iff \psi$ -->

`iff a b`, written `a <-> b`, expresses the equivalence of `a` and `b`.

> infixl 9 <->
>
> ||| The biconditional is a *binary connective* that can be voiced:
> ||| *p* **if and only if** *q*.
> public export
> (<->) : Type -> Type -> Type
> (<->) a b = (a -> b, b -> a)

=== Biconditional is Reflexive

[Proof Wiki](https://proofwiki.org/wiki/Biconditional_is_Reflexive)

$\vdash \varphi \iff \varphi$

> ||| The biconditional operator is reflexive.
> iffRefl : a <-> a
> iffRefl = Conj id id

=== Biconditional is Transitive

[Proof Wiki](https://proofwiki.org/wiki/Biconditional_is_Transitive)

 <!-- \[ -->
 <!--   \begin{prooftree} -->
 <!--     \Hypo{ \varphi \iff \psi } -->
 <!--     \Hypo{ \psi \iff \chi } -->
 <!--     \Infer2 { \vdash \varphi \iff \chi } -->
 <!--   \end{prooftree} -->
 <!-- \] -->

> ||| The biconditional operator is transitive.
> iffTrans : (a <-> b) -> (b <-> c) -> (a <-> c)
> iffTrans (Conj ab ba) (Conj bc cb) =
>     Conj (bc . ab) (ba . cb)

=== Biconditional is Commutative

[Proof Wiki](https://proofwiki.org/wiki/Biconditional_is_Commutative)

$\varphi \iff \psi \dashv\vdash \psi \iff \varphi$

or

$\vdash (\varphi \iff \psi) \iff (\psi \iff \varphi)$

> ||| The biconditional operator is commutative.
> iffSym : (a <-> b) -> (b <-> a)
> iffSym (Conj ab ba) = Conj ba ab

=== andIffCompatLeft

$\psi \iff \chi \dashv\vdash (\varphi \land \psi) \iff (\varphi \land \chi)$

> andIffCompatLeft : (b <-> c) -> ((a, b) <-> (a, c))
> andIffCompatLeft = bimap second second

=== andIffCompatRight

$\psi \iff \chi \dashv\vdash (\psi \land \varphi) \iff (\chi \land \varphi)$

> andIffCompatRight : (b <-> c) -> ((b, a) <-> (c, a))
> andIffCompatRight = bimap first first

=== orIffCompatLeft

$\psi \iff \chi \vdash (\varphi \lor \psi) \iff (\varphi \lor \chi)$

> orIffCompatLeft : (b <-> c) ->
>                   (Either a b <-> Either a c)
> orIffCompatLeft = bimap second second

=== orIffCompatRight

$\psi \iff \chi \vdash (\psi \lor \varphi) \iff (\chi \lor \varphi)$

> orIffCompatRight : (b <-> c) ->
>                    (Either b a <-> Either c a)
> orIffCompatRight = bimap first first

=== negVoid

$\neg \varphi \dashv\vdash \varphi \iff \bot$

or

$\vdash \neg \varphi \iff (\varphi \iff \bot)$

> negVoid : (~a) <-> (a <-> Void)
> negVoid = Conj (flip Conj void) proj1

=== andCancelLeft

 <!-- $\psi \implies \varphi$\ -->
 <!-- $\underline{\chi \implies \varphi}$\ -->
 <!-- $((\varphi \land \psi) \iff (\varphi \land \chi)) \iff (\psi \iff \chi)$ -->

> andCancelLeft : (b -> a) ->
>                 (c -> a) ->
>                 (((a, b) <-> (a, c)) <-> (b <-> c))
> andCancelLeft ba ca = Conj (bimap f g) andIffCompatLeft
>   where
>     f h b = proj2 . h $ Conj (ba b) b
>     g h c = proj2 . h $ Conj (ca c) c

=== andCancelRight

> andCancelRight : (b -> a) ->
>                  (c -> a) ->
>                  (((b, a) <-> (c, a)) <-> (b <-> c))
> andCancelRight ba ca = Conj (bimap f g) andIffCompatRight
>   where
>     f h b = proj1 . h $ Conj b (ba b)
>     g h c = proj1 . h $ Conj c (ca c)

=== Conjunction is Commutative

[Proof Wiki](https://proofwiki.org/wiki/Rule_of_Commutation/Conjunction)

==== Formulation 1
$\varphi \land \psi \dashv\vdash \psi \land \varphi$

==== Formulation 2
$\vdash (\varphi \land \psi) \iff (\psi \land \varphi)$

==== Source

> ||| Conjunction is commutative.
> andComm : (a, b) <-> (b, a)
> andComm = Conj swap swap
>   where
>     swap : (p, q) -> (q, p)
>     swap (Conj p q) = Conj q p

=== Conjunction is Associative

[Proof Wiki](https://proofwiki.org/wiki/Rule_of_Association/Conjunction)

==== Formulation 1
$(\varphi \land \psi) \land \chi \dashv\vdash \varphi \land (\psi \land \chi)$

==== Formulation 2
$\vdash ((\varphi \land \psi) \land \chi) \iff (\varphi \land (\psi \land \chi))$

==== Source

> ||| Conjunction is associative.
> andAssoc : ((a, b), c) <-> (a, (b, c))
> andAssoc = Conj f g
>   where
>     f abc@(Conj (Conj a b) c) = Conj a (first proj2 abc)
>     g abc@(Conj a (Conj b c)) = Conj (second proj1 abc) c

=== orCancelLeft

$(\psi \implies \neg \varphi) \implies (\chi \implies \neg \varphi) \implies (((\varphi \lor \psi) \iff (\varphi \lor \chi)) \iff (\psi \iff \chi))$

> orCancelLeft : (b -> ~a) ->
>                (c -> ~a) ->
>                ((Either a b <-> Either a c) <-> (b <-> c))
> orCancelLeft bNotA cNotA = Conj (bimap f g) orIffCompatLeft
>   where
>     f ef b = go (bNotA b) (ef (Right b))
>     g eg c = go (cNotA c) (eg (Right c))
>     go : (~a) -> Either a b -> b
>     go lf = either (void . lf) id

=== orCancelRight

 <!-- $\psi \vdash \neg \varphi$\ -->
 <!-- $\underline{\chi \vdash \neg \varphi}$\ -->
 <!-- $((\psi \lor \varphi) \iff (\chi \lor \varphi)) \iff (\psi \iff \chi)$ -->

> orCancelRight : (b -> ~a) ->
>                 (c -> ~a) ->
>                 ((Either b a <-> Either c a) <-> (b <-> c))
> orCancelRight bNotA cNotA = Conj (bimap f g) orIffCompatRight
>   where
>     f ef b = go (bNotA b) (ef (Left b))
>     g eg c = go (cNotA c) (eg (Left c))
>     go : (~p) -> Either q p -> q
>     go rf = either id (void . rf)

=== Disjunction is Commutative

[Proof Wiki](https://proofwiki.org/wiki/Rule_of_Commutation/Disjunction)

$(\varphi \lor \psi) \iff (\psi \lor \varphi)$

> ||| Disjunction is commutative.
> orComm : Either a b <-> Either b a
> orComm = Conj mirror mirror

=== Disjunction is Associative

[Proof Wiki](https://proofwiki.org/wiki/Rule_of_Association/Disjunction)

$(\varphi \lor \psi) \lor \chi \vdash \varphi \lor (\psi \lor \chi)$

> ||| Disjunction is associative on the left.
> orAssocLeft : Either (Either a b) c -> Either a (Either b c)
> orAssocLeft = either (second Left) (pure . pure)

$\varphi \lor (\psi \lor \chi) \vdash (\varphi \lor \psi) \lor \chi$

> ||| Disjunction is associative on the right.
> orAssocRight : Either a (Either b c) -> Either (Either a b) c
> orAssocRight = either (Left . Left) (first Right)

==== Formulation 1
$(\varphi \lor \psi) \lor \chi \dashv\vdash \varphi \lor (\psi \lor \chi)$

==== Formulation 2
$\vdash ((\varphi \lor \psi) \lor \chi) \iff (\varphi \lor (\psi \lor \chi))$

==== Source

> ||| Disjunction is associative.
> orAssoc : Either (Either a b) c <-> Either a (Either b c)
> orAssoc = Conj orAssocLeft orAssocRight

=== iffAnd

$\varphi \iff \psi \vdash (\varphi \implies \psi) \land (\psi \implies \varphi)$

> iffAnd : (a <-> b) -> (a -> b, b -> a)
> iffAnd = id

=== iffAndTo

$\varphi \iff \psi \dashv\vdash (\varphi \implies \psi) \land (\psi \implies \varphi)$

or

$\vdash (\varphi \iff \psi) \iff ((\varphi \implies \psi) \land (\psi \implies \varphi))$

> iffToAnd : (a <-> b) <-> (a -> b, b -> a)
> iffToAnd = Conj id id


import Data.Vect

-- Page 160

-- Exercise 1
Matrix : Nat -> Nat -> Type
Matrix n m = Vect n (Vect m Double)

-- Exercise 2
data Format = Number Format
            | Str Format
            | Lit String Format
            | Ch Format
            | Dbl Format
            | End

PrintfType : Format -> Type
PrintfType (Number fmt) = (i : Int) -> PrintfType fmt
PrintfType (Str fmt) = (str : String) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType (Ch fmt) = (c : Char) -> PrintfType fmt
PrintfType (Dbl fmt) = (d : Double) -> PrintfType fmt
PrintfType End = String

printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str)
printfFmt (Ch fmt) acc = \c => printfFmt fmt (acc ++ show c)
printfFmt (Dbl fmt) acc = \d => printfFmt fmt (acc ++ show d)
printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)
printfFmt End acc = acc

toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: 'c' :: chars) = Ch (toFormat chars)
toFormat ('%' :: 'f' :: chars) = Dbl (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
                             Lit lit chars' => Lit (strCons c lit) chars'
                             fmt => Lit (strCons c "") fmt
printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""

-- Exercise 3
TupleVect : Nat -> Type -> Type
TupleVect Z e = ()
TupleVect (S k) e = (e, TupleVect k e)

-- test : TupleVect 4 Nat
-- test = (1,2,3,4,())

-- Page 180
-- See file `week7_1_p_180.idr`

-- Page 193

data Shape = Triangle Double Double
           | Rectangle Double Double
           | Circle Double

-- Exercise 1

Eq Shape where
  (==) (Triangle a b) (Triangle a' b') = (a == a' && b == b')
  (==) (Rectangle a b) (Rectangle a' b') = (a == a' && b == b')
  (==) (Circle r) (Circle r') = (r == r')
  (==) _ _ = False

-- Exercise 2

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

Ord Shape where
  compare s1 s2 = compare (area s1) (area s2)

-- testShapes : List Shape
-- testShapes = [Circle 3, Triangle 3 9, Rectangle 2 6, Circle 4,
--               Rectangle 2 7]

-- Page 199

-- Exercise 1
data Expr num = Val num
              | Add (Expr num) (Expr num)
              | Sub (Expr num) (Expr num)
              | Mul (Expr num) (Expr num)
              | Div (Expr num) (Expr num)

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

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

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

Show t => Show (Expr t) where
  show (Val x) = show x
  show (Add x y) = "(" ++ (show x) ++ " + " ++ (show y) ++ ")"
  show (Sub x y) = "(" ++ (show x) ++ " - " ++ (show y) ++ ")"
  show (Mul x y) = "(" ++ (show x) ++ " * " ++ (show y) ++ ")"
  show (Div x y) = "(" ++ (show x) ++ " / " ++ (show y) ++ ")"

-- show (the (Expr _) (6 + 3 * 12))
-- show (the (Expr _) (6 * 3 + 12))

-- Exercise 2
(Eq num, Integral num, Neg num) => Eq (Expr num) where
    (==) x y = eval x == eval y

-- Exercise 3
(Integral num, Neg num) => Cast (Expr num) num where
  cast x = eval (x)

-- Page 206

-- Exercise 1
Functor Expr where
  map f (Val x) = Val (f x)
  map f (Add x y) = Add (map f x) (map f y)
  map f (Sub x y) = Sub (map f x) (map f y)
  map f (Mul x y) = Mul (map f x) (map f y)
  map f (Div x y) = Div (map f x) (map f y)

-- Exercise 2
-- See file `week7_1_p_206_ex_2.idr`