module BoundedVect
import Data.Vect
import NatHelpers

%default total

||| A bounded Vect is a vector with a maximum capacity that cannot be exceeded.
|||
||| The only way to append an element to the vector is to provide a prood that
||| it's size is strictly less than it's capacity. Therefore the size of a BoundedVect
||| will always be less or equal to its maximum capacity
public export
data BoundedVect : (max, size: Nat) -> (elem : Type) -> Type where
  Nil : BoundedVect max Z elem
  Cons : (prf : size `LT` max) -> (x : elem) -> BoundedVect max size elem -> BoundedVect max (S size) elem
%name BoundedVect xs, ys, zs, ws

export
fromVect : Vect size elem -> (ok : size `LTE` max) -> BoundedVect max size elem
fromVect [] ok = []
fromVect (x :: xs) ok = Cons ok x (fromVect xs (lteSuccLeft ok))

export
fromVectAuto : Vect size elem -> {auto ok : size `LTE` max} -> BoundedVect max size elem
fromVectAuto xs {ok} = fromVect xs ok

||| attempt to append an element to a bounded vect, if the vect is at max capacity
||| return nothing, otherwise, return the new boundedVect with the same bounds
export maybeAppendBoundedVect : (x : elem) -> BoundedVect max size elem -> Maybe (BoundedVect max (S size) elem)
maybeAppendBoundedVect x xs {max} {size}  with (cmp size max)
  maybeAppendBoundedVect x xs {max = (size + (S y))} {size = size} | (CmpLT y) =
    let lte = LTESucc $ lteRightPlusNat {k = y} (size) in
      Just (Cons (lteRighPlusSuccRightSucc lte) x xs)
  maybeAppendBoundedVect x xs {max = max} {size = max} | CmpEQ = Nothing
  maybeAppendBoundedVect x xs {max = max} {size = (max + (S k))} | (CmpGT k) = Nothing

||| Appends an element to a boundedVect and increase the size of its bound
export
appendVectExtendBound : (x : elem) -> BoundedVect max size elem -> BoundedVect (S max) (S size) elem
appendVectExtendBound x [] = Cons (LTESucc LTEZero) x []
appendVectExtendBound x (Cons prf y xs) with (appendVectExtendBound y xs)
  appendVectExtendBound x (Cons prf y xs) | (Cons z w ys) = Cons (LTESucc prf) w (Cons z w ys)


module Main

import public Data.Fin

%default total

{-
Terminology: parameters and indices

Vec defines a family of types.
- indexed by length
- parameterized by element type

Distinction between parameters and indices:
- parameter is unchanged across the entire structure (e.g, every element of the vector has the same type)
- index may change across a structure (e.g., every subvector has a different length)

Distinction useful when looking at function type
- specific value of a parameter can play no part in a function’s definition
- index might change definition
-}

infixr 7 :>

data Vec : Nat -> Type -> Type where
    V0   :                              Vec  Z    a
    (:>) : (x : a) -> (xs : Vec k a) -> Vec (S k) a

%name Vec xs, ys, zs

append : Vec n elem -> Vec m elem -> Vec (n + m) elem
append       V0  ys = ys
append (x :> xs) ys = x :> append xs ys

zip : Vec n a -> Vec n b -> Vec n (a, b)
zip       V0        V0  = V0
zip (x :> xs) (y :> ys) = (x, y) :> zip xs ys

{-
Fin n : unsigned number with non-inclusive upper bound of n.
name "Fin" says number is finitely bounded.

FZ and FS are constructors of Fin, corresponding to Z and S Nat constructors.
Can use numeric literals, as with Nat.
-}
index : Fin n -> Vec n a -> a
index  FZ    (x :>  _) = x
index (FS i) (_ :> ys) = index i ys

tryIndex' : Integer -> Vec n a -> Maybe a
tryIndex' _       V0  = Nothing
tryIndex' 0 (x :>  _) = Just x
tryIndex' i (_ :> xs) = tryIndex' (i - 1) xs

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

vectTake : (m : Nat) -> Vec (m + n) a -> Vec m a
vectTake  Z           _  = V0
vectTake (S k) (x :> xs) = x :> vectTake k xs

tvt : Vec (S Z) Integer
tvt = vectTake (S Z) (1:>2:>3:>4:>5:>6:>7:>V0)


module Quotient_Group

import Monoid
import Group

%access public export

||| Given a map f : g -> h, the image of f along with the proofs
total
ImageOf : (x : Type) -> (y : Type) -> (f : x -> y) -> Type
ImageOf x y f = (b : y ** (a : x ** ( (f a) = b)))

||| Generates the coset over h of a given element in g
total
Coset: (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
       (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
       (Subgroup h (+) pf1 g (*) pf2) -> (a : g) -> Type
Coset h (+) pf1 g (*) pf2 (f ** pfSub) a = (y : g ** (y1 : ImageOf h g f ** ((fst y1)*a = y)))
--Imgfn h g (\r => a*(fst(sbgrp) r))

||| The property that a particular element is in the coset
total
Is_in_Coset : (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
              (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
              (Subgroup h (+) pf1 g (*) pf2) -> (a : g) -> (b : g) -> Type

Is_in_Coset h (+) pf1 g (*) pf2 (f ** pfSub) a b = (y1 : ImageOf h g f ** ((fst y1)*a = b))

||| If b is in the coset of a, then a is in the coset of b
total
Coset_property_1 : (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
                   (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
                   (Subgroup h (+) pf1 g (*) pf2) -> (a : g) -> (b : g) ->
                   (Is_in_Coset  h (+) pf1 g (*) pf2 (f ** pfSub) a b) ->
                   (Is_in_Coset  h (+) pf1 g (*) pf2 (f ** pfSub) b a)

||| Property 2 - A proof that C(a) * C(b) and C(a*b) are equal as sets
total
Coset_property_2 : (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
                   (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
                   (Subgroup h (+) pf1 g (*) pf2) -> Type


module EqNat

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

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

public export
checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just $ Same Z
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
                         Nothing => Nothing
                         Just (Same j) => Just $ Same (S j)


module Numbers

%default total

data MyNat : Type where
     MyZ : MyNat
     MyS : MyNat -> MyNat

pred : (n : Nat) -> Nat
pred Z = Z
pred (S k) = k

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

evenb : Nat -> Bool
evenb Z = True
evenb (S (S k)) = evenb k
evenb (S k) = False
-- can also pattern match on (and have it as the 1st or 2nd option):
-- evenb (S Z) = False

oddb : Nat -> Bool
oddb = not . evenb

todd1 : oddb 1 = True
todd1 = Refl
todd2 : oddb 4 = False
todd2 = Refl

myPlus : Nat -> Nat -> Nat
myPlus Z b = b
myPlus (S k) b = S (myPlus k b)

myMult : Nat -> Nat -> Nat
myMult Z b = Z
myMult (S k) b = myPlus b (myMult k b)

tM1 : (mult 3 3) = 9
tM1 = Refl

myMinus : (uno, dos : Nat) -> Nat
myMinus Z _ = Z
myMinus a Z = a
myMinus (S k) (S j) = myMinus k j

tmi1 : (myMinus 5 3) = 2
tmi1 = Refl
tmi2 : (myMinus 0 2352) = 0
tmi2 = Refl

myExp : Nat -> Nat -> Nat
myExp _ Z = 1
myExp b (S j) = myMult b (myExp b j)

tme1 : (myExp 2 3) = 8
tme1 = Refl
tme2 : (myExp 5 2) = 25
tme2 = Refl


module InsertionSort

import Data.Vect

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

Min : (m: Nat) -> (n: Nat) -> Either (LTE m n) (LTE n m)
Min Z n = Left LTEZero
Min m Z = Right LTEZero
Min (S a) (S b) = case (Min a b) of
                       (Left l) => Left (LTESucc l)
                       (Right r) => Right (LTESucc r)

Insert: (k: Nat) -> (Vect n Nat) -> (Vect (S n) Nat)
Insert k [] = [k]
Insert k (x :: xs) = case (Min k x) of
                        (Left l) => ([k] ++ [x]) ++ xs
                        (Right r) => [x] ++ (Insert k xs)

Sort: (Vect n Nat) -> (Vect n Nat)
Sort [] = []
Sort (x :: xs) = Insert x (Sort xs)

VectMin: (n: Nat) -> (Vect n Nat) -> Nat
VectMin Z [] = Z
VectMin (S Z) [k] = k
VectMin (S (S len)) (x :: xs) = Smaller (VectMin (S len) xs) (x)

CheckSortedVect : (n: Nat) -> (Vect n Nat) -> Bool
CheckSortedVect Z [] = True
CheckSortedVect (S Z) [k] = True
CheckSortedVect (S (S n)) (x :: xs) = case (isLTE x (VectMin (S n) xs)) of
                                         (Yes prf) => (CheckSortedVect (S n) xs)
                                         (No contra) => False


module Bits

%access public export
%default total

||| Ceiling of log_2 for `Nat`s.
||| This is a bit module, so for convenience, we say clog2 0 = 0
clog2 : Nat -> Nat
clog2 Z = 0
clog2 (S Z) = 0
clog2 (S (S n)) = let y1 = log2NZ (S (S n)) SIsNotZ
                      y2 = log2NZ (S n) SIsNotZ in
                  if y1 == y2 then y1+1 else y1

||| Floor of log_2 for `Nat`s.
||| This is a bit module, so for convenience, we say flog2 0 = 0
flog2 : Nat -> Nat
flog2  Z    = 0
flog2 (S z) = log2NZ (S z) SIsNotZ

||| Round a `Double` to the closest `Nat`
round : Double -> Nat
round x = cast $ cast {to=Integer} (x+0.5)

||| Version of flog2 for `Double`
flog2Approx : Double -> Nat
flog2Approx = flog2 . round

||| Conversion of maximum unsigned value, to minimum number of bits
maxToBits : Nat -> Nat
maxToBits = clog2 . (+1)

||| Conversion of bits to maximum unsigned value
bitsToMax : Nat -> Nat
bitsToMax = Nat.pred . power 2


module Data.Rel

import Data.Fun

||| Build an n-ary relation type from a Vect of Types
public export
Rel : Vect n Type -> Type
Rel ts = Fun ts Type

||| Universal quantification of a n-ary Relation over its
||| arguments to build a (function) type from a `Rel` type
|||
||| ```
||| λ> All [Nat,Nat] LTE
||| (x : Nat) -> (x : Nat) -> LTE x x
||| ```
public export
All : (ts : Vect n Type) -> (p : Rel ts) -> Type
All [] p = p
All (t :: ts) p = (x : t) -> All ts (p x)

||| Existential quantification of a n-ary relation over its
||| arguments to build a dependent pair (eg. Sigma type).
|||
||| Given a (type of) relation `p : [t_1, t_2 ... t_n] x r` where `t_i` and `r` are
||| types, `Ex` builds the type `Σ (x_1 : t_1). Σ (x_2 : t_2) ... . r`
||| For example:
||| ```
||| λ> Ex [Nat,Nat] LTE
||| (x : Nat ** (x : Nat ** LTE x x))
||| ```
||| Which is the type of a pair of natural numbers along with a proof that the first
||| is smaller or equal than the second.
public export
Ex : (ts : Vect n Type) -> (p : Rel ts) -> Type
Ex [] p = p
Ex (t :: ts) p = (x : t ** Ex ts (p x))

||| Map a type-level function over the co-domain of a n-ary Relation
public export
liftRel : (ts : Vect n Type) -> (p : Rel ts) -> (Type -> Type) -> Type
liftRel ts p f = All ts $ map @{Nary} f p


module Proofs.GroupCancelMisc

import public Common.Abbrev
import Specifications.Group
import Symmetry.Opposite
import Proofs.GroupCancelationLemmas
import Proofs.GroupTheory

%default total
%access export

infixl 8 #

groupCancelMisc1 : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b,c : s) ->
  a # (b # inv c) # c = a # b
groupCancelMisc1 spec a b c = o1 @== cong o2 where
  o1 : a # ((b # inv c) # c) = a # (b # inv c) # c
  o1 = associative (monoid spec) _ _ _
  o2 : (b # inv c) # c = b
  o2 = groupCancel2bis spec b c

groupCancelMisc2 : {(#) : Binop s} -> GroupSpec (#) e inv -> (a,b,c : s) ->
  a # b # inv (c # b) = a # inv c
groupCancelMisc2 spec a b c = o4 @== cong o3 where
  o1 : b # inv (c # b) = b # (inv b # inv c)
  o1 = cong (groupInverseAnti spec c b)
  o2 : b # (inv b # inv c) = inv c
  o2 = groupCancel2bis (opposite spec) _ b
  o3 : b # inv (c # b) = inv c
  o3 = o1 === o2
  o4 : a # (b # inv (c # b)) = a # b # inv (c # b)
  o4 = associative (monoid spec) _ _ _


||| Euclidean division using primitive recursion/induction.
module Data.Nat.DivMod

import Data.Nat

%default total

||| The result of euclidean division of natural numbers
|||
||| @ dividend the dividend
||| @ divisor the divisor
public export
data DivMod : (dividend, divisor : Nat) -> Type where
  ||| The result of division. The order of operations and operands in the
  ||| result type was picked to not require any explicit proofs.
  |||
  ||| @ quotient the quotient
  ||| @ remainder the remainder
  ||| @ divisor the divisor
  ||| @ remainderSmall proof that the remainder is in the range
  ||| `[0 .. divisor - 1]`
  MkDivMod : (quotient, remainder : Nat) ->
             (remainderSmall : LT remainder divisor) ->
             DivMod (remainder + quotient * divisor) divisor

||| The base case, dividing zero by a successor.
|||
||| @ n the predecessor of the divisor
public export
ZDivModSn : Z `DivMod` S n
ZDivModSn = MkDivMod 0 0 (LTESucc LTEZero)

||| Given a number less than or equal to a bound, is it equal, or less?
|||
||| @ m the lesser or equal number
||| @ n the greater or equal number
||| @ mLten proof that `m` is less than or equal to `n`
public export
stepLT : {n : Nat} -> {m : Nat} -> (mLten : m `LTE` n) -> Either (m = n) (LT m n)
stepLT {m = Z} {n = Z} LTEZero = Left Refl
stepLT {m = Z} {n = (S n)} LTEZero = Right (LTESucc LTEZero)
stepLT {m = (S m)} {n = (S n)} (LTESucc mLten) with (stepLT mLten)
  stepLT {m = (S m)} {n = (S n)} (LTESucc mLten) | (Left mEqn) = Left $ cong S mEqn
  stepLT {m = (S m)} {n = (S n)} (LTESucc mLten) | (Right mLtn) = Right $ LTESucc mLtn

||| The inductive step, taking a division of `m` to a division of `S m`
|||
||| @ m the dividend in the inductive hypothesis
||| @ n the divisor
||| @ hyp the inductive hypothesis
public export
SmDivModn : {n : Nat} -> {m : Nat} -> (hyp : m `DivMod` n) -> (S m) `DivMod` n
SmDivModn {n} {m = r + q * n} (MkDivMod q r rLtn) with (stepLT rLtn)
  SmDivModn {n = S r} {m = r + q * (S r)} (MkDivMod q r rLtn) | (Left Refl) = MkDivMod (S q) 0 (LTESucc LTEZero)
  SmDivModn {n} {m = r + q * n} (MkDivMod q r rLtn) | (Right srLtn) = MkDivMod q (S r) srLtn

||| Euclidean division. Note that this takes the predecessor of the divisor to
||| avoid division by zero.
|||
||| @ dividend the dividend
||| @ predDivisor the predecessor of the desired divisor
public export
divMod : (dividend, predDivisor : Nat) -> dividend `DivMod` (S predDivisor)
divMod Z n = ZDivModSn
divMod (S m) n = SmDivModn (m `divMod` n)


{-
 - Associated YT tutorial: https://youtu.be/TEWy9vZcxW4
 -
 - Launch REPL with:
 - > idris -p contrib -p effects
 -
-}
import Util

||| Inputs (samplex x inputs)
X : Matrix 3 4 Double
X = [[1, 2, 3, 2.5],
     [2.0, 5.0, -1.0, 2.0],
     [-1.5, 2.7, 3.3, -0.8]]

||| Data structure for a dense layer
record Layer_Dense (n_inputs : Nat) (n_neurons : Nat) where
  constructor MkLayer_Dense
  weights : Matrix n_inputs n_neurons Double
  biases : Vect n_neurons Double
-- Note: can't make output a field, since we don't don't know
--       how many samples we'll be given

||| Smart constructor for a dense layer
newLayer_Dense : (n_inputs : Nat) ->
                 (n_neurons : Nat) ->
                 Eff (Layer_Dense n_inputs n_neurons) [RND]
newLayer_Dense n_inputs n_neurons = pure $
  MkLayer_Dense
    !(rndMat n_inputs n_neurons (-1) 1)
    (zeroVect n_neurons)

||| Feed inputs into the layer and compute outputs
forward : Layer_Dense i n -> Matrix m i Double -> Matrix m n Double
forward layer inputs = (inputs <> (weights layer)) <+ (biases layer)

main : IO ()
main = do
  let layer1 = runPure $ newLayer_Dense 4 5
  let layer2 = runPure $ newLayer_Dense 5 2
  let output1 = forward layer1 X
  -- printLn $ output1
  let output2 = forward layer2 output1
  printLn $ output2


module Intro
import Data.Vect
-- a term with its type
three: Nat
three = 3

-- next is a term with type the function type `Nat -> Nat`
next: Nat -> Nat
next n = S n

fct: Nat -> Nat
fct Z = 1
fct (S k) = (S k) * (fct k)

fibPair: Nat -> (Nat, Nat)
fibPair Z = (1, 1)
fibPair (S k) = case (fibPair k) of
                     (a, b) => (b, a + b)

fibo: Nat -> Nat
fibo n = fst (fibPair n)

-- Nat is itself a term with type `Type`
naturals: Type
naturals = Nat

-- as is Nat -> Nat
natToNat: Type
natToNat = Nat -> Nat

-- functions of two variables can be viewed as iterated functions by Currying
add: Nat -> Nat -> Nat
add k j = k + j

-- we can define inductive types by listing all intro rules. `BinTree` is a type
data BinTree: Type where
  Leaf: BinTree
  Node : (left: BinTree) -> (right: BinTree) -> BinTree

vertices: BinTree -> Nat
vertices Leaf = 1
vertices (Node left right) = (vertices left) + (vertices right)

-- We have labelled trees, which depend on a type.
data LTree: Type -> Type where
  LLeaf : (a: Type) -> (label: a) -> LTree a
  LNode : (a: Type) -> (left: LTree a) -> (right: LTree a) -> LTree a

vertexList: (a: Type) -> LTree a -> List a
vertexList a (LLeaf a label) = [label]
vertexList a (LNode a left right) = (vertexList a left) ++ (vertexList a right)

-- a type family
Tuple: Nat -> Type
Tuple Z = Unit
Tuple (S k) = (Nat, Tuple k)

--- countdown is a dependent function, and its type is a Pi-Type
countdown: (n: Nat) -> Tuple n
countdown Z = ()
countdown (S k) = ((S k), countdown k)

cntd : (n: Nat) -> Vect (S n) Nat
cntd Z = [0]
cntd (S k) = (S k) :: (cntd k)

append: (n: Nat) -> (a: Type) -> Vect n a -> a -> Vect (S n) a
append Z a [] x = x :: []
append (S len) a (y :: xs) x = y :: (append len a xs x)

reverse: (n: Nat) -> (a: Type) -> Vect n a -> Vect n a
reverse Z a [] = []
reverse (S len) a (x :: xs) = append len a (reverse len a xs) x

zip : (n: Nat) -> (a: Type) -> (b: Type) -> Vect n a -> Vect n b -> Vect n (a, b)
zip Z a b [] [] = []
zip (S len) a b (x :: xs) (y :: ys) = (x, y) :: (zip _ _ _ xs ys)

filter : (n: Nat) -> (a: Type) -> (vec: Vect n a) -> (p: a -> Bool) -> (m: Nat ** Vect m a)
filter Z a [] condition = (Z ** [])
filter (S len) a (x :: xs) p =
  case filter len a xs p of
        (m ** pf) => if (p x) then (S m ** x :: pf) else (m ** pf)


{- vector append in reverse order -}
module Sec8_2_5_vappd
import Data.Vect

%default total

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

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

myAppend2 : Vect n elem -> Vect m elem -> Vect (m + n) elem
myAppend2 {m} [] ys = rewrite plusZeroRightNeutral m in ys
myAppend2 (x :: xs) ys = myAppend2_xs_lemma (x :: myAppend2 xs ys)


module Group

import Monoid
%access public export

||| The proof that b is inverse of a
total
IsInverse : (typ : Type) -> ((*) : typ -> typ -> typ) -> (IdentityExists typ (*)) -> (a : typ) -> (b : typ) -> Type
IsInverse typ (*) pfid a b = ((a*b = fst(pfid)),(b*a = fst(pfid)))

||| Given a type and a binary operation the type of proofs that each element has its inverse
total
InverseExists : (typ : Type) -> ((*) : typ -> typ -> typ) -> Type
InverseExists typ (*) = (pfid : (IdentityExists typ (*)) ** ((a : typ) -> (a_inv ** (IsInverse typ (*) pfid a a_inv))))
--(pfid : (IdentityExists typ (*)) ** ((a : typ) -> (a_inv : typ ** ((a*a_inv = fst(pfid)),(a_inv*a = fst(pfid))))))

||| Given a type and a binary operation the type of proofs that the type along with the
||| operation is a group
total
IsGroup : (grp : Type) -> ((*) : grp -> grp -> grp) -> Type
IsGroup grp (*) = (Associative grp (*), (IdentityExists grp (*), InverseExists grp (*)))

||| Given a group gives it's identity with proof
total
Group_id : (grp : Type) -> ((*) : grp -> grp -> grp) -> (IsGroup grp (*)) -> (IdentityExists grp (*))
Group_id grp (*) pfgrp = (fst (snd pfgrp))

||| Generates inverses with proofs
total
Inv_with_pf : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) -> (x : grp)
              -> (y : grp ** (IsInverse grp (*) (fst (snd (snd pfgrp))) x y))
Inv_with_pf grp (*) pfgrp x = (snd (snd (snd pfgrp))) x

||| Generates inverses
total
Inv: (grp : Type) -> ((*) : grp -> grp -> grp) -> IsGroup grp (*) -> (x: grp) -> grp
Inv grp (*) pf x = fst (Inv_with_pf grp (*) pf x)
-- fst(snd(snd(snd(pf))) x)

||| Given a group, the type of proofs that it is abelian
total
IsAbelianGrp:  (grp : Type) -> ((*) : grp -> grp -> grp) -> Type
IsAbelianGrp grp (*)  = (IsGroup grp (*), Commutative grp (*))
--- (a:grp) -> (b:grp) -> (a*b = b*a)

||| The type of proofs that a given function f between x and y is injective
total
Inj: (x: Type) -> (y: Type) -> (f: x-> y) -> Type
Inj x y f = (a : x) -> (b : x) -> (f a = f b) -> (a = b)

||| The type of proofs that a function between groups is a group homomorphism
total
Hom: (grp : Type) -> ((*) : grp -> grp -> grp) -> (IsGroup grp (*)) ->
     (g : Type) -> ((+) : g -> g -> g) -> (IsGroup g (+)) ->
     (f : grp -> g) -> Type
Hom grp (*) pf1 g (+) pf2 f  = ((IsIdentity g (+) e) , (
                               (a : grp) -> (b : grp) -> ((f (a*b)) = ((f a) + (f b))))) where
                               e = f(fst (Group_id grp (*) pf1))

||| The type of proofs that a given group is a subgroup of another, via injective homorphisms
total
Subgroup: (h: Type) -> ((+) : h -> h -> h) -> (IsGroup h (+)) ->
          (g: Type) -> ((*) : g -> g -> g) -> (IsGroup g (*)) -> Type
Subgroup h (+) pfh g (*) pfg = ( f : (h -> g) **
                               (Hom h (+) pfh g (*) pfg f , Inj h g f))
--- DPair (h->g) (\f => ((Hom h (+) pfh g (*) pfg f), (Inj h g f)))

||| The type of proofs that a given subgroup is normal/self-conjugate
total
NSub: (h: Type) -> ((+) : h -> h -> h) -> (pfh: IsGroup h (+)) ->
      (g: Type) -> ((*) : g -> g -> g) -> (pfg: IsGroup g (*)) ->
      (Subgroup h (+) pfh g (*) pfg) -> Type
NSub h (+) pfh g (*) pfg (f ** pff) = (a : h) -> (b : g) -> (x : h ** (b*(f a)*(inv b) = (f x))) where
     inv = Inv g (*) pfg

--The type of proofs that a type trav traverses a given coset only once, if at all
CosetInj: (h: Type) -> ((+) : h -> h -> h) -> (pf1: IsGroup h (+)) -> (g: Type) -> ((*) : g -> g -> g) -> (pf2: IsGroup g (*)) -> (sbgrp: Subgroup h (+) pf1 g (*) pf2) -> (trav: Type) -> (f: trav -> g) -> Type
CosetInj  h (+) pf1 g (*) pf2 sbgrp trav f = ((x: trav) -> (y: trav) -> (p: h ** (f x) = (incl p)*(f y)) -> (x = y)) where
  incl = (fst sbgrp)

--The type of proofs that a type trav traverses every coset of a given group g wrt a subgroup h
CosetAll: (h: Type) -> ((+) : h -> h -> h) -> (pf1: IsGroup h (+)) -> (g: Type) -> ((*) : g -> g -> g) -> (pf2: IsGroup g (*)) -> (sbgrp: Subgroup h (+) pf1 g (*) pf2) -> (trav: Type) -> (f: trav -> g) -> Type
CosetAll h (+) pf1 g (*) pf2 sbgrp trav f = ((a: g) -> (p: h ** (t: trav ** ((f t)*(incl p) = a)))) where
  incl = (fst sbgrp)

-- Traversal type - the type of proofs that a given type traverses each coset exactly once
IsTraversal: (h: Type) -> ((+) : h -> h -> h) -> (pf1: IsGroup h (+)) -> (g: Type) -> ((*) : g -> g -> g) -> (pf2: IsGroup g (*)) -> (sbgrp: Subgroup h (+) pf1 g (*) pf2) -> (trav: Type) -> Type
IsTraversal h (+) pf1 g (*) pf2 sbgrp trav = DPair (trav -> g) (\f => (CosetInj h (+) pf1 g (*) pf2 sbgrp trav f, CosetAll h (+) pf1 g (*) pf2 sbgrp trav f))

--Defining the multiplication operation between elements of a traversal
MulTrav: (h: Type) -> ((+) : h -> h -> h) -> (pf1: IsGroup h (+)) -> (g: Type) -> ((*) : g -> g -> g) -> (pf2: IsGroup g (*)) -> (sbgrp: Subgroup h (+) pf1 g (*) pf2) -> (trav: Type) -> (IsTraversal h (+) pf1 g (*) pf2 sbgrp trav) -> trav -> trav -> trav
MulTrav h (+) pf1 g (*) pf2 sbgrp trav pftrav y z = (fst (snd ((snd (snd pftrav)) ((f y)*(f z))))) where
  f: trav -> g
  f = (fst pftrav)

--Proof of uniqueness of the coset representative in trav, in the following sense
--Proof that the operation that generates coset representative in trav for an element of g (from CosetAll) inverts the function generating a coset representative by going from trav to g (from IsTraversal)
corepfinv: (h: Type) -> ((+) : h -> h -> h) -> (pf1: IsGroup h (+)) -> (g: Type) -> ((*) : g -> g -> g) -> (pf2: IsGroup g (*)) -> (sbgrp: Subgroup h (+) pf1 g (*) pf2) -> (trav: Type) -> (pftrav: IsTraversal h (+) pf1 g (*) pf2 sbgrp trav) -> (y: trav) -> (((fst (snd ((snd (snd pftrav)) ((fst pftrav) y) ) )) ) = y)
corepfinv h (+) pf1 g (*) pf2 sbgrp trav pftrav y = (sym ((fst (snd pftrav)) y t (p ** (sym (snd (snd  ((snd (snd pftrav)) (f y)) )))) )) where
  t: trav
  t = (fst (snd ((snd (snd pftrav)) ((fst pftrav) y) ) ))
  f: trav -> g
  f = (fst pftrav)
  p: h
  p = (fst ((snd (snd pftrav)) (f y)))

--Proof that the definitional equality for traversal multiplication holds
MulTravDefPf: (h: Type) -> ((+) : h -> h -> h) -> (pf1: IsGroup h (+)) -> (g: Type) -> ((*) : g -> g -> g) -> (pf2: IsGroup g (*)) -> (sbgrp: Subgroup h (+) pf1 g (*) pf2) -> (trav: Type) -> (pftrav: IsTraversal h (+) pf1 g (*) pf2 sbgrp trav) -> (y: trav) -> (z: trav) -> (MulTrav h (+) pf1 g (*) pf2 sbgrp trav pftrav y z) = ((fst (snd ((snd (snd pftrav)) (((fst pftrav) y)*((fst pftrav) z))) )))
MulTravDefPf h (-) pf1 g (*) pf2 sbgrp trav pftrav y z = Refl

--Proof that the function from g to trav recovered from CosetAll is in some sense a magma homorphism
MulTravHomPf: (h: Type) -> ((+) : h -> h -> h) -> (pf1: IsGroup h (+)) -> (g: Type) -> ((*) : g -> g -> g) -> (pf2: IsGroup g (*)) -> (sbgrp: Subgroup h (+) pf1 g (*) pf2) -> (trav: Type) -> (pftrav: IsTraversal h (+) pf1 g (*) pf2 sbgrp trav) -> (y: trav) -> (z: trav) -> ((fst (snd ((snd (snd pftrav)) (((fst pftrav) y)*((fst pftrav) z))) ))) = (MulTrav h (+) pf1 g (*) pf2 sbgrp trav pftrav ((fst (snd ((snd (snd pftrav)) ((fst pftrav) y)) ))) ((fst (snd ((snd (snd pftrav)) ((fst pftrav) z)) ))))
MulTravHomPf h (-) pf1 g (*) pf2 sbgrp trav pftrav y z = trans (sym (MulTravDefProof)) (trans (cong {f = f1} (sym CorepFInverseY)) (cong {f = f2} (sym CorepFInverseZ))) where

  MulTravDefProof: (MulTrav h (-) pf1 g (*) pf2 sbgrp trav pftrav y z) = ((fst (snd ((snd (snd pftrav)) (((fst pftrav) y)*((fst pftrav) z))) )))
  MulTravDefProof = (MulTravDefPf h (-) pf1 g (*) pf2 sbgrp trav pftrav y z )

  f1: trav -> trav
  f1 x = MulTrav h (-) pf1 g (*) pf2 sbgrp trav pftrav x z

  f2: trav -> trav
  f2 x = MulTrav h (-) pf1 g (*) pf2 sbgrp trav pftrav ((fst (snd ((snd (snd pftrav)) ((fst pftrav) y) ) )) ) x

  CorepFInverseY: (((fst (snd ((snd (snd pftrav)) ((fst pftrav) y) ) )) ) = y)
  CorepFInverseY = CorepFInv h (-) pf1 g (*) pf2 sbgrp trav pftrav y

  CorepFInverseZ: (((fst (snd ((snd (snd pftrav)) ((fst pftrav) z) ) )) ) = z)
  CorepFInverseZ = CorepFInv h (-) pf1 g (*) pf2 sbgrp trav pftrav z


import Data.Vect

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

myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m =  m + n
myPlusCommutes Z m = rewrite sym (plusZeroRightNeutral m) in Refl
myPlusCommutes (S k) m = let rec = cong {f=S} (myPlusCommutes k m)
                         in rewrite sym (plusSuccRightSucc m k) in rec

vectLenPlusZero : Vect n a -> Vect (n + 0) a
vectLenPlusZero {n} xs = rewrite plusZeroRightNeutral n in xs

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

reverse' : Vect n a -> Vect m a -> Vect (n+m) a
reverse' xs [] = vectLenPlusZero xs
reverse' xs (x :: ys) = vectLenPlusSuccRight $ reverse' (x :: xs) ys

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


> module Nat.GCDAlgorithm

> import Nat.GCD
> import Nat.GCDProperties
> import Nat.GCDEuclid
> import Pairs.Operations
> import Sigma.Sigma

> %default total

> %access public export

> %hide gcd

> ||| The GCD algorithm
> gcdAlg : Nat -> Nat -> Nat
> gcdAlg m n = getWitness (euclidGCD m n)

> gcdAlgLemma : (m : Nat) -> (n : Nat) -> GCD (gcdAlg m n) m n
> gcdAlgLemma m n = getProof (euclidGCD m n)

> gcdAlgCommutative : (m : Nat) -> (n : Nat) -> gcdAlg m n = gcdAlg n m
> gcdAlgCommutative m n =
>   let d1  :  Nat
>           =  gcdAlg m n in
>   let d2  :  Nat
>           =  gcdAlg n m in
>   let v1  :  GCD d1 m n
>           =  gcdAlgLemma m n in
>   let v2  :  GCD d2 m n
>           =  gcdCommutative (gcdAlgLemma n m) in
>   gcdUnique d1 d2 v1 v2


-- Shamelessly stolen from Edwin Brady
module Main

pythagoras : Int -> List (Int, Int, Int)
pythagoras max = [
    (x, y, z)
    | z <- [1..max]
    , y <- [1..z]
    , x <- [1..y]
    , x * x + y *y == z * z
  ]

main : IO ()
main = do
  arg <- getLine
  printLn $ pythagoras (cast arg)


import Data.Vect

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

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

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

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

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

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

myReverse : Vect n a -> Vect n a
myReverse xs = reverse' [] xs
  where reverse' : Vect n a -> Vect m a -> Vect (n + m) a
        reverse' {n} acc [] = rewrite (plusZeroRightNeutral n) in acc
        reverse' {n} {m = S k} acc (x :: xs) =
          rewrite sym (plusSuccRightSucc n k) in (reverse' (x::acc) xs)


module Matrix

import Data.Vect
import Data.Nat
import Complex
import Lemmas

%default total

public export
Matrix : Nat -> Nat ->  Type
Matrix n m = Vect n (Vect m (Complex Double))

public export
Vector : Nat -> Type
Vector n = Vect n (Complex Double)

private
idRow : (n : Nat) -> Nat -> Vector n
idRow 0 _ = []
idRow (S k) 0 = 1 :: idRow k (S k)
idRow (S k) (S p) = 0 :: idRow k p

export
matrixId : (n : Nat) -> Matrix n n
matrixId n = matrixId' n 0 n where
  matrixId' : (k : Nat) -> (p : Nat) -> (n : Nat) -> Matrix k n
  matrixId' 0 p n = []
  matrixId' (S k) p n = (idRow n p) :: matrixId' k (S p) n

export
addVector : Vector n -> Vector n -> Vector n
addVector [] [] = []
addVector (x::xs) (y::ys) = (x+y) :: (addVector xs ys)

export
addMatrix : Matrix n m -> Matrix n m -> Matrix n m
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = (addVector x y) :: (addMatrix xs ys)

private
vectProduct : Vector n -> Vector n -> Complex Double
vectProduct [] [] = 0
vectProduct (x :: xs) (y :: ys) = x * y + vectProduct xs ys

private
makeCol : Vector n -> Matrix n 1
makeCol [] = []
makeCol (x :: xs) = [x] :: makeCol xs

private
addCol : Vector n -> Matrix n p -> Matrix n (S p)
addCol [] [] = []
addCol (x :: xs) (v :: vs) = (x :: v) :: addCol xs vs

export
transposeMatrix : {n : Nat} -> {p : Nat} ->  Matrix n p -> Matrix p n
transposeMatrix [] = replicate _ []
transposeMatrix (x :: xs) = addCol x (transposeMatrix xs)

export
multVectMatrix : {n : Nat} -> {p : Nat} ->  Vector n -> Matrix n p -> Vector p
multVectMatrix v m =
  let mt = transposeMatrix m in multVectMatrix' v mt where
    multVectMatrix' : Vector l -> Matrix k l -> Vector k
    multVectMatrix' v [] = []
    multVectMatrix' v (x :: xs) = (vectProduct v x) :: multVectMatrix' v xs

export
matrixMult : {n : Nat} -> {m : Nat} -> {p : Nat} -> Matrix n m -> Matrix m p -> Matrix n p
matrixMult [] ys = []
matrixMult (x :: xs) ys = (multVectMatrix x ys) :: matrixMult xs ys

export
multScalarVect : Complex Double -> Vector n -> Vector n
multScalarVect _ [] = []
multScalarVect x (y :: ys) = (x * y) :: multScalarVect x ys

export
multScalarMatrix : Complex Double -> Matrix n m -> Matrix n m
multScalarMatrix _ [] = []
multScalarMatrix x (y :: ys) = multScalarVect x y :: multScalarMatrix x ys

private
concatRows : Matrix n p -> Matrix n q -> Matrix n (p + q)
concatRows [] [] = []
concatRows (x :: xs) (y :: ys) = (x ++ y) :: (concatRows xs ys)

private
concatCols : Matrix n p -> Matrix m p -> Matrix (n + m) p
concatCols v w = v ++ w

private
tensorProduct' : Vector (S n) -> Matrix p r -> Matrix p ((S n) * r)
tensorProduct' [x] m = rewrite multZeroLeftZero r in rewrite plusZeroRightNeutral r in multScalarMatrix x m
tensorProduct' (x :: y :: ys) m = (multScalarMatrix x m) `concatRows` (tensorProduct' (y :: ys) m)

export
tensorProduct : Matrix n (S m) -> Matrix p r -> Matrix (n * p) ((S m) * r)
tensorProduct [] _ = []
tensorProduct [v] xs = rewrite multZeroLeftZero p in rewrite plusZeroRightNeutral p in tensorProduct' v xs
tensorProduct (v :: w :: vs) xs = (tensorProduct' v xs) `concatCols` (tensorProduct (assert_smaller (v::w::vs) (w :: vs)) xs)

export
printComplex : Complex Double -> String
printComplex (x :+ y) =
  if y == 0 then show x
            else if x == 0 then show y ++ "i"
                 else show x ++ " + " ++ show y ++ "i"

export
printVector : Vector n -> String
printVector v = "[" ++ printVector' v ++ "]" where
  printVector' : Vector m -> String
  printVector' [] = ""
  printVector' [x] = printComplex x
  printVector' (x :: xs) = printComplex x ++ " , " ++  printVector' xs

export
printMatrix : Matrix n m -> String
printMatrix v = "[ " ++ printMat' v where
  printMat' : Matrix p q -> String
  printMat' [] = ""
  printMat' [x] = printVector x ++ " ]"
  printMat' (x :: xs) = printVector x ++ "\n  " ++ printMat' xs

------------ Lemmas about matrices ---------------------------------------

export
powPlusMultZeroRightNeutral : (n : Nat) -> plus (power 2 n) (mult 0 (power 2 n)) = power 2 n
powPlusMultZeroRightNeutral n = rewrite plusZeroRightNeutral (power 2 n) in Refl

export
multPowerPowerPlus : (base, exp, exp' : Nat) ->
                     power base (exp + exp') = (power base exp) * (power base exp')
multPowerPowerPlus base Z       exp' =
    rewrite plusZeroRightNeutral (power base exp') in Refl
multPowerPowerPlus base (S exp) exp' =
  rewrite multPowerPowerPlus base exp exp' in
    rewrite sym $ multAssociative base (power base exp) (power base exp') in
       Refl

export
powPlusZeroRightNeutral : {m : Nat} -> Matrix (plus (plus (power 2 m) (plus (power 2 m) 0)) 0) 1 -> Matrix (plus (power 2 m) (plus (power 2 m) 0)) 1
powPlusZeroRightNeutral mat = rewrite sym $ plusZeroRightNeutral (plus (power 2 m) (plus (power 2 m) 0)) in mat

------------ LINEAR-ALGEBRAIC SIMULATION: MATRIX OPERATIONS ---------------

export
matrixH : Matrix 2 2
matrixH = [[(1/(sqrt 2)) :+ 0, (1/(sqrt 2)) :+ 0], [(1/(sqrt 2)) :+ 0 , (-1/(sqrt 2)) :+ 0]]

export
matrixP : Double -> Matrix 2 2
matrixP p = [[1 , 0] , [0, cis p]]

export
matrixCNOT : Matrix 4 4
matrixCNOT = [[1,0,0,0] , [0,1,0,0] , [0,0,0,1] , [0,0,1,0]]

export
matrixX : Matrix 2 2
matrixX = [[0,1] , [1,0]]

export
matrixKet0Bra0 : Matrix 2 2
matrixKet0Bra0 = [[1,0] , [0,0]]

export
matrixKet1Bra1 : Matrix 2 2
matrixKet1Bra1 = [[0,0] , [0,1]]

export
simpleTensor : Matrix 2 2 -> (n : Nat) -> Nat -> Matrix (power 2 n) (power 2 n)
simpleTensor _ 0 _ = [[1]]
simpleTensor m (S n) 0 = m `tensorProduct` (simpleTensor m n (S n))
simpleTensor m (S n) (S k) = (matrixId 2) `tensorProduct` (simpleTensor m n k)

export
tensorCnotAux : (n : Nat) -> (control : Nat) -> (target : Nat) -> Matrix (power 2 n) (power 2 n)
tensorCnotAux 0 _ _ = [[1]]
tensorCnotAux (S n) 0 0 = (matrixId 2) `tensorProduct` (tensorCnotAux n (S n) (S n)) --should not be happening
tensorCnotAux (S n) 0 (S m) = matrixKet1Bra1 `tensorProduct` (tensorCnotAux n (S n) m)
tensorCnotAux (S n) (S k) 0 = matrixX `tensorProduct` (tensorCnotAux n k (S n))
tensorCnotAux (S n) (S k) (S m) = (matrixId 2) `tensorProduct` (tensorCnotAux n k m)

export
tensorCNOT : (n : Nat) -> (control : Nat) -> (target : Nat) -> Matrix (power 2 n) (power 2 n)
tensorCNOT nbQbits control target = (simpleTensor matrixKet0Bra0 nbQbits control) `addMatrix` (tensorCnotAux nbQbits control target)

export
tensorProductVect : Matrix (power 2 n) 1 -> Matrix (power 2 p) 1 -> Matrix (power 2 (n + p)) 1
tensorProductVect xs ys =
  rewrite multPowerPowerPlus 2 n p
  in tensorProduct xs ys

export
normState2 : Matrix n 1 -> Double
normState2 [] = 0
normState2 ([x] :: xs) = let m = magnitude x in m * m + normState2 xs

export
toTensorBasis : Matrix n 2 -> Matrix (power 2 n) 1
toTensorBasis [] = [[1]]
toTensorBasis ([x,y] :: xs) = tensorProduct [[x] , [y]] (toTensorBasis xs)

export
ket0 : (n : Nat) -> Matrix n 2
ket0 0 = []
ket0 (S k) = [1 , 0] :: ket0 k

export
inv : Double -> Double
inv x = if x == 0 then 0 else 1/x

export
projectState : {n : Nat} -> Matrix (power 2 (S n)) 1 -> (i : Nat) ->
               Bool -> Matrix (power 2 n) 1
projectState v 0 b =
  let (v1, v2) = splitAt (power 2 n) v in
      case b of
           True => rewrite sym $ powPlusMultZeroRightNeutral n in v2
           False => v1
projectState {n = 0} _ (S k) _ = [[1]]
projectState {n = S m} v (S k) b =
  let (v1, v2) = splitAt (power 2 (S m)) v
      v1' = projectState {n = m} v1 k b
      v2' = projectState {n = m} (powPlusZeroRightNeutral v2) k b
  in rewrite plusZeroRightNeutral (power 2 m) in v1' ++ v2'


module Algebra.Solver.Monoid

import Algebra.Monoid
import Syntax.PreorderReasoning

%default total

public export
data Expr : (a : Type) -> Type where
  Var     : (x : a) -> Expr a
  Neutral : Expr a
  Append  : Expr a -> Expr a -> Expr a

public export
Semigroup (Expr a) where
  (<+>) = Append

public export
Monoid (Expr a) where
  neutral = Neutral

public export
eval : LMonoid a => Expr a -> a
eval (Var x)      = x
eval Neutral      = neutral
eval (Append x y) = eval x <+> eval y

--------------------------------------------------------------------------------
--          Sum
--------------------------------------------------------------------------------

public export
esum : LMonoid a => List a -> a
esum []       = neutral
esum (h :: t) = h <+> esum t

public export
normalize : Expr a -> List a
normalize (Var x)      = x :: []
normalize Neutral      = []
normalize (Append x y) = normalize x ++ normalize y

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

0 psum :  LMonoid a
       => (xs,ys : List a)
       -> esum (xs ++ ys) === esum xs <+> esum ys
psum []        ys = sym appendLeftNeutral
psum (x :: xs) ys = Calc $
  |~ x <+> esum (xs ++ ys)
  ~~ x <+> (esum xs <+> esum ys) ... cong (x <+>) (psum xs ys)
  ~~ (x <+> esum xs) <+> esum ys ... appendAssociative

0 pnorm : LMonoid a => (e : Expr a) -> eval e === esum (normalize e)
pnorm (Var x)      = sym appendRightNeutral
pnorm Neutral      = Refl
pnorm (Append x y) = Calc $
  |~ eval x <+> eval y
  ~~ esum (normalize x) <+> eval y
     ... cong (<+> eval y) (pnorm x)
  ~~ esum (normalize x) <+> esum (normalize y)
     ... cong (esum (normalize x) <+>) (pnorm y)
  ~~ esum (normalize x ++ normalize y)
     ..< psum (normalize x) (normalize y)

--------------------------------------------------------------------------------
--          Solver
--------------------------------------------------------------------------------

export
0 solve :  LMonoid a
        => (e1,e2 : Expr a)
        -> (prf : normalize e1 === normalize e2)
        => eval e1 === eval e2
solve e1 e2 = Calc $
  |~ eval e1
  ~~ esum (normalize e1) ... pnorm e1
  ~~ esum (normalize e2) ... cong esum prf
  ~~ eval e2             ..< pnorm e2

--------------------------------------------------------------------------------
--          Example
--------------------------------------------------------------------------------

0 solverExample : {x,y,z : String}
                -> x ++ ((y ++ "") ++ z) === ("" ++ x) ++ (y ++ z)
solverExample =
  solve (Var x <+> ((Var y <+> Neutral) <+> Var z))
        ((Neutral <+> Var x) <+> (Var y <+> Var z))


module ArithSeq

%access export
%default total

namespace Preloaded

  %access public export
  %default total

  arithSum : Nat -> Nat
  arithSum Z = Z
  arithSum (S n) = S n + arithSum n

  -- We define our own function for dividing a natural
  -- number by 2.
  -- The existing Idris function divNatNZ
  -- is not a good choice because it is impossible (correct
  -- me if I my wrong) to prove many useful properties of
  -- divNatNZ.
  half : Nat -> Nat
  half (S (S n)) = S (half n)
  half _ = Z

  arithFormula : Nat -> Nat
  arithFormula n = half $ n * (n + 1)

lemma_half_puts_out : (k, x : Nat) -> half (k + (k + x)) = k + half x
lemma_half_puts_out Z     x = Refl
lemma_half_puts_out (S k) x = rewrite sym $ plusSuccRightSucc k (k + x) in
                              rewrite lemma_half_puts_out k x in
                              Refl

arithEq : (n : Nat) -> arithFormula n = arithSum n
arithEq Z     = Refl
arithEq (S k) = rewrite plusCommutative k 1 in
                rewrite multCommutative k (S (S k)) in
                rewrite lemma_half_puts_out k (k + k*k) in
                rewrite multCommutative (S k) k in
                rewrite plusCommutative 1 k in
                rewrite arithEq k in
                Refl


module Part2.Sez10_2b
import Part2.Sez10_2a_snoc

%default total

isSuffix : Eq a => List a -> List a -> Bool
isSuffix input1 input2 with (snocList input1)
    isSuffix [] input2 | Empty = True
    isSuffix (xs ++ [x]) input2 | (Snoc rec1) with (snocList input2)
        isSuffix (xs ++ [x]) [] | (Snoc rec1) | Empty = False
        isSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc rec1) | (Snoc rec2)
              = if x == y then isSuffix xs ys | rec1 | rec2 else False

{-
idris repl:
*Part2/Sez10_2b> isSuffix [7,8,9,10] [1..10]
True : Bool
*Part2/Sez10_2b> isSuffix [7,8,9] [1..10]
False : Bool
-}


module TypesAndFunctions

import Data.List
import Data.Strings
import Data.Vect

%default total

-- data types

data MyNat = MZ | MS MyNat

mynat2int : MyNat -> Int
mynat2int MZ = 0
mynat2int (MS n) = 1 + mynat2int n

partial
int2mynat : Int -> MyNat
int2mynat 0 = MZ
int2mynat n = MS (int2mynat (n - 1))

plus : MyNat -> MyNat -> MyNat
plus MZ m = m
plus (MS n) m = MS (plus n m)

mult : MyNat -> MyNat -> MyNat
mult MZ _ = MZ
mult (MS n) m = plus m (mult n m)

infixr 10 ::

data MyList a = Nil | (::) a (MyList a)

Show a => Show (MyList a) where
  show Nil = "Nil"
  show (x :: xs) = "(Cons " ++ show x ++ " " ++ show xs ++ ")"

len : MyList a -> Nat
len Nil = Z
len (_ :: xs) = S (len xs)

fromList : List a -> MyList a
fromList [] = Nil
fromList (x :: xs) = (::) x (fromList xs)

-- where clauses

myReverse : List a -> List a
myReverse xs = aux xs [] where
  aux : List a -> List a -> List a
  aux [] acc = acc
  aux (x :: xs) acc = aux xs (x :: acc)

-- till https://github.com/idris-lang/Idris2/issues/588 is fixed, this
-- definition has to be in the top-level
data MyLT = Yes | No

foo : Int -> Int
foo x = case isLT of
            Yes => x * 2
            No => x * 4 where
              isLT : MyLT
              isLT = if x < 10 then Yes else No

even : Nat -> Bool
even Z = True
even (S k) = odd k where
  odd : Nat -> Bool
  odd Z = False
  odd (S k) = even k

test : List Nat
test = [c (S 1), c Z, d (S Z)] where
  c : Nat -> Nat
  c x = 42 + x

  d : Nat -> Nat
  d y = c (y + 1 + z y) where
    z : Nat -> Nat
    z w = y + w

-- totality and covering

partial
from : Maybe a -> a
from (Just x) = x

-- dependent types

isSingleton : Bool -> Type
isSingleton False = List Nat
isSingleton True = Nat

mkSingle : (x : Bool) -> isSingleton x
mkSingle False = []
mkSingle True = 0

mysum : (single : Bool) -> isSingleton single -> Nat
mysum False [] = 0
mysum False (n :: ns) = n + mysum False ns
mysum True d = d

-- declaration order and mutual blocks

mutual
  myeven : Nat -> Bool
  myeven Z = True
  myeven (S k) = myodd k

  myodd : Nat -> Bool
  myodd Z = False
  myodd (S k) = myeven k

greet : HasIO io => io ()
greet = do putStr "What is your name? "
           name <- getLine
           putStrLn $ "Nice to meet you, " ++ name

-- laziness
{-
  data Lazy : Type -> Type where
    Delay : (val : a) -> Lazy a

  Force : Lazy a -> a
-}

myIfThenElse : Bool -> Lazy a -> Lazy a -> a
myIfThenElse True t e = t
myIfThenElse False t e = e

-- infinite data types (codata)

{-
  data Stream : Type -> Type where
    (::) : (e : a) -> Inf (Stream a) -> Stream a
-}

ones : Stream Nat
ones = 1 :: ones

-- useful data types

{-
  data List a = Nil | (::) a (List a)

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

{-
  map : (a -> b) -> List a -> List b
  map _ [] = []
  map f (x :: xs) = f x :: map f xs

  map : (a -> b) -> Vect n a -> Vect n b
  map _ [] = []
  map f (x :: xs) = f x :: map f xs
-}

intVec : Vect 5 Int
intVec = [1, 2, 3, 4, 5]

double : Int -> Int
double x = x + x

listLookup : Nat -> List a -> Maybe a
listLookup _ [] = Nothing
listLookup Z (x :: _) = Just x
listLookup (S k) (_ :: xs) = listLookup k xs

-- tuples

{-
  data Pair : Type -> Type -> Type where
    MkPair : a -> b -> Pair a b
-}

fred : (String, Nat)
fred = ("Fred", 42)

jim : (String, Int, String)
jim = ("Jim", 25, "Cambridge")

-- dependent pairs (Signma Types)

{-
  data DPair : (a : Type) -> (p : a -> Type) -> Type where
    MkDPair : {p : a -> Type} -> (x : a) -> p x -> DPair a p
-}

data DepPair : (a : Type) -> (p : a -> Type) -> Type where
  MkDepPair : { p : a -> Type } -> (x : a) -> p x -> DepPair a p

vec : (n : Nat ** Vect n Int)
vec = (3 ** [1, 2, 3])

vec1 : DPair Nat (\n => Vect n Int)
vec1 = MkDPair 3 [1, 2, 3]

vec2 : DepPair Nat (\n => Vect n Int)
vec2 = MkDepPair 3 [1, 2, 3]

vec3 : (n : Nat ** Vect n String)
vec3 = (_ ** ["Hello", "world"])

vec4 : (n ** Vect n Double)
vec4 = (_ ** [1.0, 2.2, -2.1212])

vFilter : (a -> Bool) -> Vect n a -> (p : Nat ** Vect p a)
vFilter p [] = (0 ** [])
vFilter p (x :: xs) = case p x of
                           False => vFilter p xs
                           True => let (_ ** res) = vFilter p xs in
                                       (_ ** (x :: res))

-- let bindings

mirror : List a -> List a
mirror xs = let xs' = reverse xs in
                 xs ++ xs'

data Person = MkPerson String Int

showPerson : Person -> String
showPerson p = let MkPerson name age = p in
                   name ++ " is " ++ show age ++ " years old"

-- list comprehensions

pythag : Int -> List (Int, Int, Int)
pythag n = [(x, y, z) | z <- [1..n], y <- [1..z], x <- [1..y], x * x + y * y == z * z]

-- case expressions

partial
mySplitAt : Char -> String -> (String, String)
mySplitAt c cs = case break (== c) cs of
                      (h, t) => (h, strTail t)


module Exercises.Chapter9

%access  public export
%default total

namespace List

  -- Exercise 9.1.6.1

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

  -- Exercise 9.1.6.2

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

  notLastNil : Not (Last [] value)
  notLastNil LastOne      impossible
  notLastNil (LastCons _) impossible

  notTha1 : Not (x = value) -> Not (Last [x] value)
  notTha1 contra  LastOne       = contra Refl
  notTha1 _      (LastCons nil) = notLastNil nil

  noWay : Not (xs = []) -> Not (Last xs value) -> Not (Last (x :: xs) value)
  noWay contra _       LastOne       = absurd (contra Refl)
  noWay _      contra (LastCons prf) = contra prf

  isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
  isLast [] _ = No notLastNil
  isLast (x :: xs) value with (isLast xs value)
    | Yes prf = Yes (LastCons prf)
    | No callate with (decEq xs [])
      isLast (x::_) value | _ | Yes Refl with (decEq x value)
        isLast [_] _ | _ | _ | Yes Refl = Yes LastOne
        | No sucka = No (notTha1 sucka)
      | No jose = No (noWay jose callate)


module MergeSort
import Data.List.Views as V

%hide merge
%hide sort
%default total

lteOrGte : (x, y : Nat) -> Either (LTE x y) (GTE x y)
lteOrGte Z _ = Left LTEZero
lteOrGte _ Z = Right LTEZero
lteOrGte (S k) (S j) with (lteOrGte k j)
    | (Left ltekj) = Left (LTESucc ltekj)
    | (Right gtekj) = Right (LTESucc gtekj)

notLTE : Not (LTE x y) -> LTE y x
notLTE {x = x} {y = y} contra with (lteOrGte x y)
    | (Left ltexy) = absurd (contra ltexy)
    | (Right gtexy) = gtexy

data Permutation : List a -> List a -> Type where
    PermNil : Permutation [] []
    PermCons : Permutation xs xs' -> Permutation (x::xs) (x::xs')
    PermSwap : Permutation (y::x::xs) (x::y::xs)
    PermTrans : Permutation xs ys -> Permutation ys zs -> Permutation xs zs

permRefl : Permutation xs xs
permRefl {xs = []} = PermNil
permRefl {xs = x :: xs} =
    PermCons (permRefl {xs = xs})

permSym : Permutation xs ys -> Permutation ys xs
permSym PermNil = PermNil
permSym (PermCons p) = PermCons (permSym p)
permSym PermSwap = PermSwap
permSym (PermTrans p1 p2) = PermTrans (permSym p2) (permSym p1)

permAppFront : Permutation xs xs' -> Permutation (ys ++ xs) (ys ++ xs')
permAppFront {ys = []} p = p
permAppFront {ys = (y :: ys)} p =
    PermCons (permAppFront p)

permAppBack : Permutation xs xs' -> Permutation (xs ++ ys) (xs' ++ ys)
permAppBack PermNil = permRefl
permAppBack (PermCons p) = PermCons (permAppBack p)
permAppBack PermSwap = PermSwap
permAppBack (PermTrans p1 p2) =
    let ih1 = permAppBack p1 in
    let ih2 = permAppBack p2 in
    PermTrans ih1 ih2

permAppComm : Permutation (xs ++ ys) (ys ++ xs)
permAppComm {xs = []} {ys = ys} =
    rewrite appendNilRightNeutral ys in
    permRefl
permAppComm {xs = (x :: xs)} {ys = []} =
    rewrite appendNilRightNeutral (x :: xs) in
    permRefl
permAppComm {xs = (x :: xs)} {ys = (y :: ys)} =
    let ih1 = permAppComm {xs = xs} {ys = ys} in
    let ih2 = permAppComm {xs = (x::xs)} {ys = ys} in
    let ih3 = permAppComm {xs = xs} {ys = (y::ys)} in
    PermTrans
        (PermCons (PermTrans ih3 (PermCons (permSym ih1))))
        (PermTrans PermSwap (PermCons ih2))

data All : (a -> Type) -> List a -> Type where
    AllNil : All p []
    AllCons : p x -> All p xs -> All p (x::xs)

allLTEtrans : LTE x y -> All (LTE y) ys -> All (LTE x) ys
allLTEtrans _ AllNil = AllNil
allLTEtrans ltexy (AllCons py allys) =
    AllCons (lteTransitive ltexy py) (allLTEtrans ltexy allys)

allAppend : All p xs -> All p ys -> All p (xs ++ ys)
allAppend AllNil pa = pa
allAppend (AllCons px allx) ally =
    AllCons px (allAppend allx ally)

allPerm : All p xs -> Permutation xs ys -> All p ys
allPerm _ PermNil = AllNil
allPerm (AllCons p1 all) (PermCons p2) = AllCons p1 (allPerm all p2)
allPerm (AllCons p1 (AllCons p2 all)) PermSwap = (AllCons p2 (AllCons p1 all))
allPerm allxs (PermTrans p1 p2) = allPerm (allPerm allxs p1) p2

data Ordered : List Nat -> Type where
    OrdNil : Ordered []
    OrdCons : Ordered xs -> All (\x => y `LTE` x) xs -> Ordered (y::xs)

orderedSingle : Ordered [x]
orderedSingle = OrdCons OrdNil AllNil

mergeLemma : All (LTE x) xs -> All (LTE y) ys -> LTE x y -> Permutation (xs ++ y::ys) zs ->
     All (LTE x) zs
mergeLemma xsltex ysltey ltexy p =
    let ysltex = allLTEtrans ltexy ysltey in
    let yssltex = AllCons ltexy ysltex in
    allPerm (allAppend xsltex yssltex) p

merge : (xs : List Nat) -> Ordered xs -> (ys : List Nat) -> Ordered ys ->
    (zs : List Nat ** (Ordered zs, Permutation (xs ++ ys) zs))
merge [] _ ys ordys =
    (ys ** (ordys, permRefl))
merge xs ordxs [] _ =
    rewrite appendNilRightNeutral xs in
    (xs ** (ordxs, permRefl))
merge (x::xs) (OrdCons ordxs p1) (y::ys) (OrdCons ordys p2) with (isLTE x y)
    | Yes ltexy =
        let (zs ** (ordzs, permzs)) = (merge xs ordxs (y::ys) (OrdCons ordys p2)) in
        let ordxzs = OrdCons ordzs (mergeLemma p1 p2 ltexy permzs) in
        (x::zs ** (ordxzs, PermCons permzs))
    | No contra =
        let (zs ** (ordzs, permzs)) = merge (x::xs) (OrdCons ordxs p1) ys ordys in
        let ordyzs = OrdCons ordzs (mergeLemma p2 p1 (notLTE contra) (PermTrans permAppComm permzs)) in
        let tmp = PermCons (PermTrans permAppComm permzs) in
        let permyzs = PermTrans (permAppComm {xs = (x::xs)}) tmp in
        (y::zs ** (ordyzs, permyzs))

mergeSortLemma : Permutation xs1 xs -> Permutation ys1 ys ->
    Permutation (xs ++ ys) zs -> Permutation (xs1 ++ ys1) zs
mergeSortLemma p1 p2 p =
    PermTrans (permAppFront p2) (PermTrans (permAppBack p1) p)

mergeSort : (xs : List Nat) -> (ys : List Nat ** (Ordered ys, Permutation xs ys))
mergeSort xs with (V.splitRec xs)
    mergeSort [] | SplitRecNil = ([] ** (OrdNil, permRefl))
    mergeSort [x] | SplitRecOne = ([x] ** (orderedSingle, permRefl))
    mergeSort (ys ++ zs) | SplitRecPair ysrec zsrec =
        let (rs1 ** (ordrs1, permrs1)) = (mergeSort ys | ysrec) in
        let (rs2 ** (ordrs2, permrs2)) = (mergeSort zs | zsrec) in
        let (rs ** (ordrs, permrs)) = merge rs1 ordrs1 rs2 ordrs2 in
        (rs ** (ordrs, mergeSortLemma permrs1 permrs2 permrs))


mult_0_r : (n : Nat) -> n * 0 = 0
mult_0_r Z = Refl
mult_0_r (S k) =
    let indHypothesis = mult_0_r k in
        rewrite indHypothesis in Refl

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

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

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

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

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

total
double_plus : (n : Nat) -> double n = n + n
double_plus Z = Refl
double_plus (S k) = rewrite double_plus k in rewrite plus_n_Sm k k in Refl

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

total
not_involutive : (b : Bool) -> not (not b) = b
not_involutive True = Refl
not_involutive False = Refl

total
evenb_S : (n : Nat) -> evenb (S n) = not (evenb n)
evenb_S Z = Refl
evenb_S (S k) = rewrite evenb_S k in rewrite not_involutive (evenb k) in Refl

total
plus_rearrange : (n, m, p, q : Nat) -> (n + m) + (p + q) = (m + n) + (p + q)
plus_rearrange n m p q = rewrite plus_comm n m in Refl

total
plus_swap : (n, m, p : Nat) -> n + (m + p) = m + (n + p)
plus_swap n m p =
    rewrite plus_assoc n m p in
        rewrite plus_comm n m in
            rewrite plus_assoc m n p in Refl

mult_n_Sk : (n, k : Nat) -> n * (S k) = n + (n * k)
mult_n_Sk Z k = Refl
mult_n_Sk (S j) k =
    rewrite mult_n_Sk j k in
        rewrite plus_swap k j (mult j k) in
            Refl

total
mult_comm : (m, n : Nat) -> m * n = n * m
mult_comm Z n = rewrite mult_0_r n in Refl
mult_comm (S k) n = rewrite mult_n_Sk n k in rewrite mult_comm k n in Refl

total
le_refl : (n : Nat) -> lte n n = True
le_refl Z = Refl
le_refl (S k) = rewrite le_refl k in Refl

zero_nbeq_S : (n : Nat) -> 0 == (S n) = False
zero_nbeq_S n = Refl

andb_false_r : (b : Bool) -> b && False = False
andb_false_r False = Refl
andb_false_r True = Refl

plus_ble_compat_l : (n, m, p : Nat) -> lte n m = True -> lte (p + n) (p + m) = True
plus_ble_compat_l n m Z prf = prf
plus_ble_compat_l n m (S k) prf = rewrite plus_ble_compat_l n m k prf in Refl

S_nbeq_0 : (n : Nat) -> (S n) == 0 = False
S_nbeq_0 n = Refl

mult_1_l : (n : Nat) -> 1 * n = n
mult_1_l n = rewrite plus_0_r n in Refl

all3_spec : (b, c : Bool) -> (b && c) || ((not b) || (not c)) = True
all3_spec False c = Refl
all3_spec True False = Refl
all3_spec True True = Refl

total
mult_plus_distr_r : (n, m, p : Nat) -> (n + m) * p = (n * p) + (m * p)
mult_plus_distr_r Z m p = Refl
mult_plus_distr_r (S k) m p =
    rewrite mult_plus_distr_r k m p in
        rewrite plus_assoc p (k * p) (m * p) in
            Refl

total
mult_assoc : (n, m, p : Nat) -> n * (m * p) = (n * m) * p
mult_assoc Z m p = Refl
mult_assoc (S k) m p =
    rewrite mult_assoc k m p in
        rewrite mult_plus_distr_r m (mult k m) p in
            Refl

total
beq_nat_refl : (n : Nat) -> True = n == n
beq_nat_refl Z = Refl
beq_nat_refl (S k) = rewrite beq_nat_refl k in Refl

total
plus_swap' : (n, m, p : Nat) -> n + (m + p) = m + (n + p)
plus_swap' n m p =
    rewrite plus_assoc n m p in
        rewrite plus_assoc m n p in
            rewrite plus_comm n m in
                Refl

data Bin : Type where
    Z : Bin
    Odd : Bin -> Bin
    Even : Bin -> Bin

incr : Bin -> Bin
incr Z = Odd Z
incr b@(Odd x) = Even b
incr b@(Even x) = Odd b

binToNat : Bin -> Nat
binToNat Z = Z
binToNat (Odd x) = 1 + binToNat x
binToNat (Even x) = 1 + binToNat x

bin_to_nat_pres_incr : (b : Bin) -> S (binToNat b) = binToNat $ incr b
bin_to_nat_pres_incr Z = Refl
bin_to_nat_pres_incr (Odd x) = Refl
bin_to_nat_pres_incr (Even x) = Refl

natToBin : Nat -> Bin
natToBin Z = Z
natToBin (S (S k)) = Even (natToBin k)
natToBin (S k) = Odd (natToBin k)

nat_conv_full_cycle : (n : Nat) -> binToNat $ natToBin n = n
nat_conv_full_cycle Z = Refl
nat_conv_full_cycle (S k) = ?nat_conv_full_cycle_rhs_2


||| Additional properties/lemmata of Nats
module Data.Nat.Properties

import Data.Nat
import Syntax.PreorderReasoning

%default total

export
unfoldDouble : {0 n : Nat} -> (2 * n) === (n + n)
unfoldDouble = irrelevantEq $ cong (n +) (plusZeroRightNeutral _)

export
unfoldDoubleS : {0 n : Nat} -> (2 * S n) === (2 + 2 * n)
unfoldDoubleS = irrelevantEq $ Calc $
  |~ 2 * S n
  ~~ S n + S n   ...( unfoldDouble {n = S n} )
  ~~ 2 + (n + n) ...( sym (plusSuccRightSucc (S n) n) )
  ~~ 2 + 2 * n   ...( cong (2 +) (sym unfoldDouble) )

export
multRightCancel : (a,b,r : Nat) -> (0 _ : NonZero r) -> a*r = b*r -> a = b
multRightCancel a      b    0           r_nz ar_eq_br = void (absurd r_nz)
multRightCancel 0      0    r@(S predr) r_nz ar_eq_br = Refl
multRightCancel 0     (S b) r@(S predr) r_nz ar_eq_br impossible
multRightCancel (S a)  0    r@(S predr) r_nz ar_eq_br impossible
multRightCancel (S a) (S b) r@(S predr) r_nz ar_eq_br =
  cong S $ multRightCancel a b r r_nz
         $ plusLeftCancel r (a*r) (b*r) ar_eq_br


module Proofs.RingTheory

import Specifications.Ring
import Proofs.GroupCancelationLemmas
import Proofs.GroupTheory
import Symmetry.Opposite

%default total
%access export

zeroAbsorbsL : {(+) : Binop s} -> {(*) : Binop s} ->
  RingSpec (+) zero neg (*) -> (x : s) -> zero * x = zero
zeroAbsorbsL {zero} spec x = o4 where
  o1 : zero + zero = zero
  o1 = neutralL (monoid (group spec)) zero
  o2 : (zero + zero) * x = zero * x + zero * x
  o2 = distributativeR spec zero zero x
  o3 : zero * x = zero * x + zero * x
  o3 = cong {f = (* x)} o1 @== o2
  o4 : zero * x = zero
  o4 = groupCancelGivesNeutral (group spec) _ _ (sym o3)

zeroAbsorbsR : {(*) : Binop s} ->
  RingSpec _ zero _ (*) -> (x : s) -> x * zero = zero
zeroAbsorbsR spec = zeroAbsorbsL (multiplicativeOpposite spec)

negatedMultiplication : {(+) : Binop s} -> {(*) : Binop s} ->
  RingSpec (+) zero neg (*) -> (x,y : s) ->
    neg (x * y) = x * neg y
negatedMultiplication spec x y = o4 where
  o1 : x * (y + neg y) = x * y + x * neg y
  o1 = distributativeL spec x y _
  o2 : x * (y + neg y) = x * zero
  o2 = cong $ inverseR (group spec) y
  o3 : x * y + x * neg y = zero
  o3 = o1 @== o2 === zeroAbsorbsR spec x
  o4 : neg (x * y) = x * neg y
  o4 = groupInverseUnique (group spec) (x * y) _ o3


plusidex1 : (n, m : Nat) -> (n = m) -> n + n = m + m
plusidex1 n m prf = rewrite prf in Refl

-- Exercise 8.1
plusidex2 : (n, m, o : Nat) -> (n = m) -> (m = o) -> n + m = m + o
plusidex2 n m o prf prf1 = rewrite prf in (rewrite prf1 in Refl)

-- Exercise 8.2
multS1 : (n, m : Nat) -> (m = S n) -> m * (1 + n) = m * m
multS1 n m prf = rewrite prf in Refl

-- Random practice proof
mu : (n, m : Nat) -> (m = 50) -> (n = m + 50) -> 200 = n + n
mu n m prf prf1 = rewrite prf1 in rewrite prf in Refl


module LTE_Properties

-- properties of LTE

%access public export
%default total

LTE_Property1 : (a : Nat) -> (LTE a a)
LTE_Property1 Z = LTEZero
LTE_Property1 (S k) = LTESucc (LTE_Property1 k)

LTE_Property2 : (a, x, y : Nat) -> (LTE a x) -> (LTE x y) -> (LTE a y)
LTE_Property2 Z x y pf1 pf2 = LTEZero
LTE_Property2 (S k) (S l) (S m) (LTESucc pf1) (LTESucc pf2) =
    LTESucc (LTE_Property2 k l m pf1 pf2)


import Data.Vect

NatOrError : Nat -> Type
NatOrError Z = String
NatOrError (S k) = Nat

divide : Nat -> (divisor:Nat) -> NatOrError divisor
divide k Z = "Division by 0 is not defined"
divide k (S j) = div k (S j)

{-
data Vect : (n:Nat) -> (a: Type) -> Type where
  VNil : Vect 0 a
  VCons : (head : a) -> (tail : Vect k a) -> Vect (S k) a

vtake : {m:Nat} -> (n:Nat) -> Vect (n+m) a -> Vect n a
vtake Z x = VNil
vtake (S k) (VCons head tail) = VCons head (vtake k tail)

vtake2 : (n:Nat) -> Vect m a -> { auto prf : LTE n m } -> Vect n a
vtake2 Z x = VNil
vtake2 (S k) (VCons head tail) {prf = (LTESucc y)} = VCons head (vtake2 k tail)

vdrop : (n:Nat) -> Vect (n+m) a -> Vect m a
vdrop Z x = x
vdrop (S k) (VCons head tail) = vdrop k tail
-}

Fun : Nat -> Type
Fun Z = Nat
Fun (S k) = Nat -> (Fun k)

adder : ( n:Nat ) -> (acc:Nat) -> Fun n
adder Z acc = acc
adder (S k) acc = \x => adder k (acc + x)

{-
vappend : Vect n a -> Vect m a -> Vect (n+m) a
vappend VNil y = y
vappend (VCons head tail) y = VCons head (vappend tail y)
-}

Matrix : Nat -> Nat -> Type
Matrix k j = Vect k (Vect j Int)

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

whatever : (row : Vect m Int) -> (transposed : Matrix m len) -> Vect m (Vect (S len) Int)
whatever row transposed = zipWithV (::) row transposed

transposeMat : Matrix n m -> Matrix m n
transposeMat {m} [] = replicate m []
transposeMat (row :: rows) = let transposed = transposeMat rows in
                             whatever row transposed

vectMult : Vect n Int -> Vect n Int -> Int
vectMult [] [] = 0
vectMult (x :: xs) (y :: ys) = x * y + vectMult xs ys

multVectMat : (row : Vect m Int) -> (transposed : Matrix k m) -> Vect k Int
multVectMat row [] = []
multVectMat row (x :: xs) = vectMult row x :: multVectMat row xs

multMat : Matrix n m -> Matrix m k -> Matrix n k
multMat [] [] = []
multMat [] (x :: xs) = []
multMat (row :: rows) y = let transposed = transposeMat y in
                       multVectMat row transposed :: multMat rows y --?x --multVect row transposed

idRow : (i:Nat) -> { auto prf: LT i n } ->  Vect n Int
idRow {n = Z} i = []
idRow {n = (S k)} Z = 1 :: replicate k 0
idRow {n = (S k)} (S j) {prf = (LTESucc x)} = 0 :: idRow j

idMatHelper : (i:Nat) -> ( prf : LTE i n ) ->  Matrix i n
idMatHelper Z LTEZero = []
idMatHelper (S left) (LTESucc x) = idRow left :: idMatHelper left (lteSuccRight x)

idMat : Matrix n n
idMat {n} = reverse $ idMatHelper n lteRefl

--mult : Matrix 2 4 -> Matrix 4 3 -> Matrix 2 3


= ProofObjects : The Curry-Howard Correspondence

> module ProofObjects
>

\say{\textit{Algorithms are the computational content of proofs.}}
-- Robert Harper

> import Logic
> import IndProp
>

We have seen that Idris has mechanisms both for _programming_, using inductive
data types like \idr{Nat} or \idr{List} and functions over these types, and for
_proving_ properties of these programs, using inductive propositions (like
\idr{Ev}), implication, universal quantification, and the like. So far, we have
mostly treated these mechanisms as if they were quite separate, and for many
purposes this is a good way to think. But we have also seen hints that Idris's
programming and proving facilities are closely related. For example, the keyword
\idr{data} is used to declare both data types and propositions, and \idr{->} is
used both to describe the type of functions on data and logical implication.
This is not just a syntactic accident! In fact, programs and proofs in Idris are
almost the same thing. In this chapter we will study how this works.

We have already seen the fundamental idea: provability in Idris is represented
by concrete _evidence_. When we construct the proof of a basic proposition, we
are actually building a tree of evidence, which can be thought of as a data
structure.

If the proposition is an implication like \idr{A -> B}, then its proof will be
an evidence _transformer_: a recipe for converting evidence for \idr{A} into
evidence for \idr{B}. So at a fundamental level, proofs are simply programs that
manipulate evidence.

Question: If evidence is data, what are propositions themselves?

Answer: They are types!

Look again at the formal definition of the \idr{Ev} property.

```idris
data Ev : Nat -> Type where
  Ev_0 : Ev Z
  Ev_SS : {n : Nat} -> Ev n -> Ev (S (S n))
```

Suppose we introduce an alternative pronunciation of "\idr{:}". Instead of "has
type," we can say "is a proof of." For example, the second line in the
definition of \idr{Ev} declares that \idr{Ev_0 : Ev 0}. Instead of "\idr{Ev_0}
has type \idr{Ev 0}," we can say that "\idr{Ev_0} is a proof of \idr{Ev 0}."

This pun between types and propositions — between \idr{:} as "has type" and
\idr{:} as "is a proof of" or "is evidence for" — is called the Curry-Howard
correspondence. It proposes a deep connection between the world of logic and the
world of computation:

                 propositions  ~  types
                 proofs        ~  data values

\todo[inline]{Add http://dl.acm.org/citation.cfm?id=2699407 as a link}

See [Wadler 2015] for a brief history and an up-to-date exposition.

Many useful insights follow from this connection. To begin with, it gives us a
natural interpretation of the type of the \idr{Ev_SS} constructor:

```idris
λΠ> :t Ev_SS
Ev_SS : Ev n -> Ev (S (S n))
```

This can be read "\idr{Ev_SS} is a constructor that takes two arguments — a
number \idr{n} and evidence for the proposition \idr{Ev n} — and yields evidence
for the proposition \idr{Ev (S (S n))}."

Now let's look again at a previous proof involving \idr{Ev}.

> ev_4 : Ev 4
> ev_4 = Ev_SS {n=2} $ Ev_SS {n=0} Ev_0

As with ordinary data values and functions, we can use the \idr{:printdef}
command to see the proof object that results from this proof script.

```idris
λΠ> :printdef ev_4
ev_4 : Ev 4
ev_4 = Ev_SS (Ev_SS Ev_0)
```

As a matter of fact, we can also write down this proof object directly, without
the need for a separate proof script:

```idris
λΠ> Ev_SS $ Ev_SS Ev_0
Ev_SS (Ev_SS Ev_0) : Ev 4
```

The expression \idr{Ev_SS {n=2} $ Ev_SS {n=0} Ev_0} can be thought of as
instantiating the parameterized constructor \idr{Ev_SS} with the specific
arguments \idr{2} and \idr{0} plus the corresponding proof objects for its
premises \idr{Ev 2} and \idr{Ev 0}. Alternatively, we can think of \idr{Ev_SS}
as a primitive "evidence constructor" that, when applied to a particular number,
wants to be further applied to evidence that that number is even; its type,

```idris
      {n : Nat} -> Ev n -> Ev (S (S n))
```

expresses this functionality, in the same way that the polymorphic type
\idr{{x : Type} -> List x} expresses the fact that the constructor \idr{Nil} can
be thought of as a function from types to empty lists with elements of that
type.

\todo[inline]{Edit or remove}

We saw in the `Logic` chapter that we can use function application syntax to
instantiate universally quantified variables in lemmas, as well as to supply
evidence for assumptions that these lemmas impose. For instance:

```coq
Theorem ev_4': ev 4.
Proof.
  apply (ev_SS 2 (ev_SS 0 ev_0)).
Qed.
```

We can now see that this feature is a trivial consequence of the status the
Idris grants to proofs and propositions: Lemmas and hypotheses can be combined
in expressions (i.e., proof objects) according to the same basic rules used for
programs in the language.

== Proof Scripts

\ \todo[inline]{Rewrite, keep explanation about holes? Seems a bit late for
that}

The _proof objects_ we've been discussing lie at the core of how Idris operates.
When Idris is following a proof script, what is happening internally is that it
is gradually constructing a proof object — a term whose type is the proposition
being proved. The expression on the right hand side of \idr{=} tell it how to
build up a term of the required type. To see this process in action, let's use
the `Show Proof` command to display the current state of the proof tree at
various points in the following tactic proof.

```coq
Theorem ev_4'' : ev 4.
Proof.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_0.
  Show Proof.
Qed.
```

At any given moment, Idris has constructed a term with a "hole" (indicated by
`?Goal` here, and so on), and it knows what type of evidence is needed to fill
this hole.

Each hole corresponds to a subgoal, and the proof is finished when there are no
more subgoals. At this point, the evidence we've built stored in the global
context under the name given in the type definition.

Tactic proofs are useful and convenient, but they are not essential: in
principle, we can always construct the required evidence by hand, as shown
above. Then we can use `Definition` (rather than `Theorem`) to give a global
name directly to a piece of evidence.

```coq
Definition ev_4''' : ev 4 :=
  ev_SS 2 (ev_SS 0 ev_0).
```

All these different ways of building the proof lead to exactly the same evidence
being saved in the global environment.

```coq
Print ev_4.
(* ===> ev_4    =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'.
(* ===> ev_4'   =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4''.
(* ===> ev_4''  =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'''.
(* ===> ev_4''' =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
```

==== Exercise: 1 star (eight_is_even)

\ \todo[inline]{Remove?}

Give a tactic proof and a proof object showing that \idr{Ev 8}.

> ev_8 : Ev 8
> ev_8 = ?ev_8_rhs

$\square$

==== Quantifiers, Implications, Functions

\ \todo[inline]{Edit the section}

In Idris's computational universe (where data structures and programs live),
there are two sorts of values with arrows in their types: _constructors_
introduced by \idr{data} definitions, and _functions_.

Similarly, in Idris's logical universe (where we carry out proofs), there are
two ways of giving evidence for an implication: constructors introduced by
\idr{data}-defined propositions, and... functions!

For example, consider this statement:

> ev_plus4 : Ev n -> Ev (4 + n)
> ev_plus4 x = Ev_SS $ Ev_SS x

What is the proof object corresponding to `ev_plus4`?

We're looking for an expression whose type is
\idr{{n: Nat} -> Ev n -> Ev (4 + n)} — that is, a function that takes two
arguments (one number and a piece of evidence) and returns a piece of evidence!
Here it is:

```coq
Definition ev_plus4' : forall n, ev n -> ev (4 + n) :=
  fun (n : Nat) => fun (H : ev n) =>
    ev_SS (S (S n)) (ev_SS n H).
```

Recall that \idr{\n => blah} means "the function that, given \idr{n}, yields
\idr{blah}," and that Idris treats \idr{4 + n} and \idr{S (S (S (S n)))} as
synonyms. Another equivalent way to write this definition is:

```coq
Definition ev_plus4'' (n : Nat) (H : ev n) : ev (4 + n) :=
  ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4''.
(* ===> ev_plus4'' : forall n : Nat, ev n -> ev (4 + n) *)
```

When we view the proposition being proved by \idr{ev_plus4} as a function type,
one aspect of it may seem a little unusual. The second argument's type,
\idr{Ev n}, mentions the _value_ of the first argument, \idr{n}. While such
_dependent types_ are not found in conventional programming languages, they can
be useful in programming too, as the recent flurry of activity in the functional
programming community demonstrates.

\todo[inline]{Reword?}

Notice that both implication (\idr{->}) and quantification
(\idr{(x : t) -> f x}) correspond to functions on evidence. In fact, they are
really the same thing: \idr{->} is just a shorthand for a degenerate use of
quantification where there is no dependency, i.e., no need to give a name to the
type on the left-hand side of the arrow.

For example, consider this proposition:

> ev_plus2 : Type
> ev_plus2 = (n : Nat) -> (e : Ev n) -> Ev (n + 2)

A proof term inhabiting this proposition would be a function with two arguments:
a number \idr{n} and some evidence \idr{e} that \idr{n} is even. But the name
\idr{e} for this evidence is not used in the rest of the statement of
\idr{ev_plus2}, so it's a bit silly to bother making up a name for it. We could
write it like this instead:

> ev_plus2' : Type
> ev_plus2' = (n : Nat) -> Ev n -> Ev (n + 2)

In general, "\idr{p -> q}" is just syntactic sugar for "\idr{(_ : p) -> q}".

== Programming with Tactics

\ \todo[inline]{Edit and move to an appendix about ElabReflection/Pruviloj?}

If we can build proofs by giving explicit terms rather than executing tactic
scripts, you may be wondering whether we can build _programs_ using _tactics_
rather than explicit terms. Naturally, the answer is yes!

```coq
Definition add1 : Nat -> Nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n. Defined.

Print add1.
(* ==>
    add1 = fun n : Nat => S n
         : Nat -> Nat
*)

Compute add1 2.
(* ==> 3 : Nat *)
```

Notice that we terminate the `Definition` with a `.` rather than with `:=`
followed by a term. This tells Idris to enter _proof scripting mode_ to build an
object of type \idr{Nat -> Nat}. Also, we terminate the proof with `Defined`
rather than `Qed`; this makes the definition _transparent_ so that it can be
used in computation like a normally-defined function. (`Qed`-defined objects are
opaque during computation.)

This feature is mainly useful for writing functions with dependent types, which
we won't explore much further in this book. But it does illustrate the
uniformity and orthogonality of the basic ideas in Idris.

== Logical Connectives as Inductive Types

Inductive definitions are powerful enough to express most of the connectives and
quantifiers we have seen so far. Indeed, only universal quantification (and thus
implication) is built into Idris; all the others are defined inductively. We'll
see these definitions in this section.

=== Conjunction

\ \todo[inline]{Edit}

To prove that \idr{(p,q)} holds, we must present evidence for both \idr{p} and
\idr{q}. Thus, it makes sense to define a proof object for \idr{(p,q)} as
consisting of a pair of two proofs: one for \idr{p} and another one for \idr{q}.
This leads to the following definition.

> data And : (p, q : Type) -> Type where
>   Conj : p -> q -> And p q

Notice the similarity with the definition of the \idr{Prod} type, given in
chapter `Poly`; the only difference is that \idr{Prod} takes Type arguments,
whereas and takes Prop arguments.

```idris
data Prod : (x, y : Type) -> Type where
  PPair : x -> y -> Prod x y
```

This should clarify why pattern matching can be used on a conjunctive
hypothesis. Case analysis allows us to consider all possible ways in which
\idr{(p,q)} was proved — here just one (the \idr{Conj} constructor). Similarly,
the `split` tactic actually works for any inductively defined proposition with
only one constructor. In particular, it works for \idr{And}:

> and_comm : (And p q) <-> (And q p)
> and_comm = (\(Conj x y) => Conj y x,
>             \(Conj y x) => Conj x y)

This shows why the inductive definition of `and` can be manipulated by tactics
as we've been doing. We can also use it to build proofs directly, using
pattern-matching. For instance:

> and_comm'_aux : And p q -> And q p
> and_comm'_aux (Conj x y) = Conj y x

> and_comm' : (And p q) <-> (And q p)
> and_comm' {p} {q} = (and_comm'_aux {p} {q}, and_comm'_aux {p=q} {q=p})

==== Exercise: 2 stars, optional (conj_fact)

Construct a proof object demonstrating the following proposition.

> conj_fact : And p q -> And q r -> And p r
> conj_fact pq qr = ?conj_fact_rhs

$\square$

=== Disjunction

The inductive definition of disjunction uses two constructors, one for each side
of the disjunct:

> data Or : (p, q : Type) -> Type where
>   IntroL : p -> Or p q
>   IntroR : q -> Or p q

This declaration explains the behavior of pattern matching on a disjunctive
hypothesis, since the generated subgoals match the shape of the \idr{IntroL} and
\idr{IntroR} constructors.

Once again, we can also directly write proof objects for theorems involving
\idr{Or}, without resorting to tactics.

==== Exercise: 2 stars, optional (or_comm)

\ \todo[inline]{Edit}

Try to write down an explicit proof object for \idr{or_comm} (without using
`Print` to peek at the ones we already defined!).

> or_comm : Or p q -> Or q p
> or_comm pq = ?or_comm_rhs

$\square$

=== Existential Quantification

To give evidence for an existential quantifier, we package a witness \idr{x}
together with a proof that \idr{x} satisfies the property \idr{p}:

> data Ex : (p : a -> Type) -> Type where
>   ExIntro : (x : a) -> p x -> Ex p

This may benefit from a little unpacking. The core definition is for a type
former \idr{Ex} that can be used to build propositions of the form \idr{Ex p},
where \idr{p} itself is a function from witness values in the type \idr{a} to
propositions. The \idr{ExIntro} constructor then offers a way of constructing
evidence for \idr{Ex p}, given a witness \idr{x} and a proof of \idr{p x}.

The more familiar form \idr{(x ** p x)} desugars to an expression involving
\idr{Ex}:

\todo[inline]{Edit}

```coq
Check ex (fun n => ev n).
(* ===> exists n : Nat, ev n
        : Prop *)
```

Here's how to define an explicit proof object involving \idr{Ex}:

> some_nat_is_even : Ex (\n => Ev n)
> some_nat_is_even = ExIntro 4 (Ev_SS $ Ev_SS Ev_0)

==== Exercise: 2 stars, optional (ex_ev_Sn)

Complete the definition of the following proof object:

> ex_ev_Sn : Ex (\n => Ev (S n))
> ex_ev_Sn = ?ex_ev_Sn_rhs

$\square$

\subsection{\idr{Unit} and \idr{Void}}

The inductive definition of the \idr{Unit} proposition is simple:

```idris
data Unit : Type where
  () : Unit
```

It has one constructor (so every proof of \idr{Unit} is the same, so being given
a proof of\idr{Unit} is not informative.)

\idr{Void} is equally simple — indeed, so simple it may look syntactically wrong
at first glance!

\todo[inline]{Edit, this actually is wrong, stdlib uses \idr{runElab} to define
it}

```idris
data Void : Type where
```

That is, \idr{Void} is an inductive type with _no_ constructors — i.e., no way
to build evidence for it.

== Equality

\ \todo[inline]{Edit, it actually is built in}

Even Idris's equality relation is not built in. It has the following inductive
definition. (Actually, the definition in the standard library is a small variant
of this, which gives an induction principle that is slightly easier to use.)

> data PropEq : {t : Type} -> t -> t -> Type where
>   EqRefl : PropEq x x

> syntax [x] "='" [y] = PropEq x y

The way to think about this definition is that, given a set \idr{t}, it defines
a _family_ of propositions "\idr{x} is equal to \idr{y}," indexed by pairs of
values (\idr{x} and \idr{y}) from \idr{t}. There is just one way of constructing
evidence for each member of this family: applying the constructor \idr{EqRefl}
to a type \idr{t} and a value \idr{x : t} yields evidence that \idr{x} is equal
to \idr{x}.

\todo[inline]{Edit}

We can use \idr{EqRefl} to construct evidence that, for example, \idr{2 = 2}.
Can we also use it to construct evidence that \idr{1 + 1 = 2}? Yes, we can.
Indeed, it is the very same piece of evidence! The reason is that Idris treats
as "the same" any two terms that are _convertible_ according to a simple set of
computation rules. These rules, which are similar to those used by `Compute`,
include evaluation of function application, inlining of definitions, and
simplification of `match`es.

> four : (2 + 2) =' (1 + 3)
> four = EqRefl

The \idr{Refl} that we have used to prove equalities up to now is essentially
just an application of an equality constructor.

\todo[inline]{Edit}

In tactic-based proofs of equality, the conversion rules are normally hidden in
uses of `simpl` (either explicit or implicit in other tactics such as
`reflexivity`). But you can see them directly at work in the following explicit
proof objects:

```coq
Definition four' : 2 + 2 = 1 + 3 :=
  eq_refl 4.
```

> singleton : ([]++[x]) =' (x::[])
> singleton = EqRefl

> quiz6 : Ex (\x => (x + 3) =' 4)
> quiz6 = ExIntro 1 EqRefl

==== Exercise: 2 stars (equality__leibniz_equality)

The inductive definition of equality corresponds to _Leibniz equality_: what we
mean when we say "\idr{x} and \idr{y} are equal" is that every property \idr{p}
that is true of \idr{x} is also true of \idr{y}.

> equality__leibniz_equality : (x =' y) -> ((p : t -> Type) -> p x -> p y)
> equality__leibniz_equality eq p px = ?equality__leibniz_equality_rhs

$\square$

==== Exercise: 5 stars, optional (leibniz_equality__equality)

Show that, in fact, the inductive definition of equality is _equivalent_ to
Leibniz equality:

> leibniz_equality__equality : ((p : t -> Type) -> p x -> p y) -> (x =' y)
> leibniz_equality__equality pxy = ?leibniz_equality__equality_rhs

$\square$

=== Inversion, Again

\ \todo[inline]{Edit/remove}

We've seen `inversion` used with both equality hypotheses and hypotheses about
inductively defined propositions. Now that we've seen that these are actually
the same thing, we're in a position to take a closer look at how `inversion`
behaves.

In general, the `inversion` tactic...

  - takes a hypothesis `H` whose type `P` is inductively defined, and

  - for each constructor `C` in `P`'s definition,

    - generates a new subgoal in which we assume `H` was built with `C`,

    - adds the arguments (premises) of `C` to the context of the subgoal as
      extra hypotheses,

    - matches the conclusion (result type) of `C` against the current goal and
      calculates a set of equalities that must hold in order for `C` to be
      applicable,

    - adds these equalities to the context (and, for convenience, rewrites them
      in the goal), and

    - if the equalities are not satisfiable (e.g., they involve things like
      \idr{S n = Z}), immediately solves the subgoal.

_Example_: If we invert a hypothesis built with \idr{Or}, there are two
constructors, so two subgoals get generated. The conclusion (result type) of the
constructor (\idr{Or p q}) doesn't place any restrictions on the form of \idr{p}
or \idr{q}, so we don't get any extra equalities in the context of the subgoal.

_Example_: If we invert a hypothesis built with \idr{And}, there is only one
constructor, so only one subgoal gets generated. Again, the conclusion (result
type) of the constructor (\idr{And p q}) doesn't place any restrictions on the
form of \idr{p} or \idr{q}, so we don't get any extra equalities in the context
of the subgoal. The constructor does have two arguments, though, and these can
be seen in the context in the subgoal.

_Example_: If we invert a hypothesis built with \idr{PropEq}, there is again
only one constructor, so only one subgoal gets generated. Now, though, the form
of the \idr{EqRefl} constructor does give us some extra information: it tells us
that the two arguments to \idr{PropEq} must be the same! The `inversion` tactic
adds this fact to the context.


module Induction

%default total

plusZeroReduces : (n : Nat) -> n + 0 = n
plusZeroReduces Z = refl
plusZeroReduces (S k) = let ind = plusZeroReduces k in ?plusZeroSucc

Induction.plusZeroSucc = proof
  intros
  rewrite ind
  trivial

minusDiag : (n : Nat) -> minus n n = Z
minusDiag Z = refl
minusDiag (S k) = let ih = minusDiag k in ?minusDiagNeutral

Induction.minusDiagNeutral = proof
  intros
  rewrite ih
  trivial

multZeroIsZero : (n : Nat) -> mult n Z = Z
multZeroIsZero Z = refl
multZeroIsZero (S k) = let ih = multZeroIsZero k in ?multSuccByZeroIsZero

Induction.multSuccByZeroIsZero = proof
  intros
  rewrite ih
  trivial

plusNSuccMRefl : (left : Nat) -> (right : Nat) -> S (left + right) = left + (S right)
plusNSuccMRefl Z right = refl
plusNSuccMRefl (S k) right = let ih = plusNSuccMRefl k right in ?plusSuccRefl

Induction.plusSuccRefl = proof
  intros
  rewrite ih
  trivial

plusCommutes : (left : Nat) -> (right : Nat) -> left + right = right + left
plusCommutes Z right = ?plusCommutesBaseCase
plusCommutes (S left) right = let ih = plusCommutes left right in ?plusCommutesSuccCase

Induction.plusCommutesBaseCase = proof
  intro
  rewrite sym (plusZeroReduces right)
  trivial

Induction.plusCommutesSuccCase = proof
  intros
  rewrite (plusNSuccMRefl right left)
  rewrite ih
  trivial

plusAssoc : (a : Nat) -> (b : Nat) -> (c : Nat) -> a + (b + c) = (a + b) + c
plusAssoc Z b c = ?plusAssocBaseCase
plusAssoc (S a) b c = let ih = plusAssoc a b c in ?plusAssocStepCase

Induction.plusAssocBaseCase = proof
  intros
  trivial

Induction.plusAssocStepCase = proof
  intros
  rewrite ih
  trivial

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

doublePlusRefl : (n : Nat) -> double n = n + n
doublePlusRefl Z = refl
doublePlusRefl (S n) = let ih = doublePlusRefl n in ?doublePlusStepCase

Induction.doublePlusStepCase = proof
  intros
  rewrite sym ih
  rewrite (plusNSuccMRefl n n)
  trivial

plusRearrange : (a:Nat) -> (b:Nat) -> (c:Nat) -> (d:Nat) -> (a + b) + (c + d) = (b + a) + (c + d)
plusRearrange a b c d = ?plusRearrangeBase

Induction.plusRearrangeBase = proof
  intros
  rewrite (plusCommutes a b)
  trivial

plusSwap : (a:Nat) -> (b:Nat) -> (c:Nat) -> a + (b + c) = b + (a + c)
plusSwap = ?plusSwapProof

Induction.plusSwapProof = proof
  intros
  rewrite sym (plusAssoc b a c)
  rewrite (plusCommutes b a)
  rewrite (plusCommutes a b)
  rewrite(plusAssoc a b c)
  trivial


data Vect : Nat -> Type -> Type where
  Nil : Vect Z a
  (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a
%name Vect xs, ys, zs

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

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

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2)
checkEqNat Z Z = Just Refl
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S j) (S k) = do
  eq <- checkEqNat j k
  pure (cong eq)

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

same_cons : (xs : List a) -> (ys : List a) ->
            (xs = ys) -> (x :: xs = x :: ys)
same_cons xs xs 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 : ty) -> (b : ty) -> (c : ty) -> Type where
  Same3 : (a : ty) -> ThreeEq a a a

allSameS : ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS (Same3 j) = Same3 (S j)

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

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

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

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


module nat.split

||| The type of evidence I'll accept for m < n:
||| some k and evidence for m+(k+1)=n
data LTProof : Nat -> Nat -> Type where
     MkLTProof : (m:Nat) -> (n:Nat) -> (k:Nat) -> (m+(k+1)=n) -> LTProof m n

||| The type of evidence I'll accept for m < n:
||| some k and evidence for m+(k+1)=n
data GTEProof : Nat -> Nat -> Type where
    MkGTEProof : (m:Nat) -> (n:Nat) -> (k:Nat) -> (m=n+k) -> GTEProof m n

data SplitNatProof : Nat -> Type where
  Below : LTProof m n -> SplitNatProof n
  Above : GTEProof m n -> SplitNatProof n

||| Take (m,n) and return either proof that m <n or proof that m>=n
split : (m:Nat) -> (n:Nat) -> SplitNatProof n
split Z n = Below (MkLTProof n n n ?hole_3)
split (S k) n = ?hole_2
--split m Z = Above MkGTEProof m Z m refl
--split Z S k = Below MkLTProof Z S k k refl

--SplitNat : (n:Nat) -> DPair Nat (SplitNatProof n)


module IdrisPrelude

%hide Prelude.Nat.Nat

data Nat : Type where
  Zero : Nat
  Succ : Nat -> Nat

natElim : (m : Nat -> Type) -> (mz : m Zero) -> (ms : (l : Nat) -> m l -> m (Succ l)) -> (k : Nat) -> m k
natElim m mz ms Zero = mz
natElim m mz ms (Succ k) = ms k (natElim m mz ms k)

data Vec : Type -> Nat -> Type where
  Nil : (a : Type) -> Vec a Zero
  Cons : (a : Type) -> (n : Nat) -> (x : a) -> (xs : Vec a n) -> Vec a (Succ n)

data Eq : (a : Type) -> a -> a -> Type where
  Refl : (a : Type) -> (x : a) -> Eq a x x


{- Support code -}

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

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

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

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

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

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

%name Tree tree, tree1

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

{- Answers -}

{- 1 -}

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

{- 2 -}

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

{- 3 -}

data Expr = Val Int
          | Add Expr Expr
          | Sub Expr Expr
          | Mult Expr Expr

{- 4 -}

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

{- 5 -}

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

{- 6 -}

biggestTriangle : Picture -> Maybe Double
biggestTriangle (Primitive tri@(Triangle x y)) = Just (area tri)
biggestTriangle (Primitive _) = Nothing
biggestTriangle (Combine x y) = maxMaybe (biggestTriangle x) (biggestTriangle y)
biggestTriangle (Rotate x pic) = biggestTriangle pic
biggestTriangle (Translate x y pic) = biggestTriangle pic


module SignedSetoid
import SignedInt
import Setoid

%default total
%access public export

signedReflx : Reflx SignedEq
signedReflx (SInt p n) = SignedRefl Refl

signedSymm : Symm SignedEq
signedSymm (SInt p1 n1) (SInt p2 n2) (SignedRefl sr) = SignedRefl (sym sr)

signedTrans : Trans SignedEq
signedTrans (SInt p1 n1) (SInt p2 n2) (SInt p3 n3) (SignedRefl sr12) (SignedRefl sr23) = SignedRefl sr13
  where
    _1 : (p1 + n2) + (p2 + n3) = ((p2 + n1) + p3) + n2
    _1  = trans (rewrite sr12 in rewrite sr23 in Refl) (plusAssociative (p2 + n1) p3 n2)

    _2 : ((p2 + n3) + p1) + n2 = (p1 + n2) + (p2 + n3)
    _2 = trans (sym (plusAssociative (p2 + n3) p1 n2)) (sym (plusCommutative (p1 + n2) (p2 + n3)))

    _3 : (p2 + n3) + p1 = (p2 + n1) + p3
    _3 = plusRightCancel _ _ n2 (trans _2 _1)

    _4 : (n3 + p1) + p2 = (p2 + n3) + p1
    _4 = trans (plusCommutative (n3 + p1) p2) (plusAssociative p2 n3 p1)

    _5 : (p2 + n1) + p3 = (n1 + p3) + p2
    _5 = sym (trans (plusCommutative (n1 + p3) p2) (plusAssociative p2 n1 p3))

    _6 : n3 + p1 = n1 + p3
    _6 = plusRightCancel _ _ p2 (trans (trans _4 _3) _5)

    sr13 : p1 + n3 = p3 + n1
    sr13 = trans (trans (plusCommutative p1 n3) _6) (plusCommutative n1 p3)

SignedSetoid : Setoid
SignedSetoid = MkSetoid SignedInt SignedEq (EqProof SignedEq signedReflx signedSymm signedTrans)


module Control.Permutation.Mod

import Prelude.Nat
import Data.List
import Data.Vect
import Control.Permutation.Types
import Data.Vect

%default total

%access public export

mutual
  even : Nat -> Bool
  even Z = True
  even (S k) = odd k

  odd : Nat -> Bool
  odd Z = False
  odd (S k) = even k

private
natToFin : (n : Nat) -> Fin (S n)
natToFin Z = FZ
natToFin (S k) = FS k' where k' = natToFin k

||| This permutation reverses a vector completely
reverse : Permutation n
reverse {n=Z} = []
reverse {n=S _} = last :: reverse

private
finiteL : (n : Nat) -> Vect (S n) (Fin (S n))
finiteL Z = FZ :: Nil
finiteL n@(S m) = natToFin n :: (map weaken $ finiteL m)

factorial : Nat -> Nat
factorial Z = S Z
factorial (S k) = (S k) * factorial k

combine : Vect m (a -> b) -> Vect n a -> Vect (m * n) b
combine {m} {n} fs xs = rewrite multCommutative m n in
                                concat $ map (g fs) xs
  where
    g : Vect m (a -> b) -> a -> Vect m b
    g fs x = fs <*> pure x

||| All permutations of a certain order.
export
enumerateStrict : Vect (factorial n) (Permutation n)
enumerateStrict {n=Z} = Nil :: Nil
enumerateStrict {n=S Z} = ((FZ :: Nil) :: Nil)
enumerateStrict {n=n@(S m)} = combine (map (::) (finiteL m)) enumerateStrict

||| Show where an integer is sent.
||| @p A permutation
||| @m The integer
fixNat : (p : Permutation n) -> (m : Fin n) -> Fin n
fixNat p m = index m $ (toVector p)
  where
    index : Fin l -> Lazy (Vect l e) -> e
    index FZ     (x::xs) = x
    index (FS k) (x::xs) = index k xs

||| Orbit generated by a given element.
||| @p A permutation
||| @i The starting point
orbit : (p : Permutation (S n)) -> (i : Fin (S n)) -> Stream (Fin (S n))
orbit p {n} i = i :: go i where
  go : Fin (S n) -> Stream (Fin (S n))
  go j = next :: go next where
    next : Fin (S n)
    next = fixNat p j

||| Return the orbit of some permutation.
finOrbit : Permutation (S n) -> Fin (S n) -> List (Fin (S n))
finOrbit p {n} i = nub $ take (S n) (orbit p i)

||| Return a list of disjoint cycles given a permutation. We use this for our
||| pretty-printer.
export
cycles : Permutation (S n) -> List (List (Fin (S n)))
cycles p {n} = nubBy g . map (finOrbit p) . enumFromTo 0 $ (natToFin n)
  where
    g : List (Fin (S n)) -> List (Fin (S n)) -> Bool
    g x y = and $ map (Delay . flip elem y) x

export
order : Permutation (S n) -> Nat
order = foldr lcm 1 . map length . cycles

private
checkId : String -> String
checkId "" = "id"
checkId x = x

implementation Show (Permutation (S n)) where
  show {n} p = checkId (concatMap (go n) (cycles p))
    where
      go : (Show a) => Nat -> List a -> String
      go _ l@(_::_::_) = if n <= 9
        then "(" ++ concatMap show l ++ ")"
        else "(" ++ concat ((intersperse "," . map show) l) ++ ")"
      go _ _ = ""

private
fill : Fin n -> Permutation n
fill FZ = neutral
fill (FS k) = FS (zeros k) :: fill k
  where zeros : Fin m -> Fin m
        zeros FZ = FZ
        zeros (FS _) = FZ

||| The permutation π_ij
export
pi : Fin n -> Fin n -> Permutation n
pi (FS j) (FS k) = FZ :: pi j k
pi (FS j) FZ = FS j :: fill j
pi FZ (FS k) = FS k :: fill k
pi FZ FZ = neutral

||| For S_4, (1234)
export
circulate : Permutation n
circulate {n=Z} = Nil
circulate {n=S Z} = FZ :: Nil
circulate {n=S (S m)} = foldl (<+>) neutral pis
  where
    pis : List (Permutation (S (S m)))
    pis = zipWith pi (enumFromTo 0 (weaken $ natToFin m)) (enumFromTo 1 (natToFin (S m)))

||| Factors a permutation into a product of swaps.
export
swaps : Permutation n -> List (Permutation n)
swaps {n=Z} _ = []
swaps {n=n@(S _)} p = go overlaps p
  where
    go : (List (Fin (S n)) -> List (Permutation (S n))) -> Permutation (S n) -> List (Permutation (S n))
    go f p = (>>= f) $ cycles p
    overlaps (x::xs@(y::ys)) = pi x y :: overlaps xs
    overlaps x = []

||| Test whether a permutation is even.
export
isEven : Permutation n -> Bool
isEven = even . length . swaps


module Koans.ListComprehensions

-- | What is the result of the List Comprehension.
listCompZero : Bool
listCompZero = ?fillme1 == [ x + x | x <- [1..5] ]

-- | Write a list comprehension that returns all the numbers divisible by four, doubled.
myFirstListComp : List Integer -> List Integer
myFirstListComp xs = ?fillme2

computeList : Bool
computeList = myFirstListComp [1..10] == [8,16]

-- | Return all the numbers between 20 and 100 that are divisible by 9.
divisibleByNine : List Integer
divisibleByNine = ?fillme3

-- | Using list comprehensions construct a function that turns a list of numbers into a list of strings.
-- Odd numbers should be bang, Even numbers boom.
boomBangs : List Integer -> List String
boomBangs xs = ?fillme4
               where
                 transform : Integer -> String
                 transform = ?fillme5

doBoomBangs : Bool
doBoomBangs = boomBangs [3,4,5,6,7] == ["bang", "boom", "bang", "boom", "bang"]


module Graphexamples

import Graph
import data.Vect

am1 :(Vect 6 (Vect 6  Nat))
am1 = [[0,1,1,0,0,0],[1,0,1,0,0,0],[1,1,0,0,0,0],[0,0,0,0,1,0],[0,0,0,1,0,1],[0,0,0,0,1,0]]
am2:(Vect 6 (Vect 6  Nat))
am2 = [[0,1,1,0,0,0],[1,0,1,1,0,0],[1,1,0,0,0,1],[0,1,0,0,1,0],[0,0,0,1,0,1],[0,0,1,0,1,0]]
am3:(Vect 6 (Vect 6  Nat))
am3=[[0,1,1,0,0,0],[1,0,1,1,0,0],[1,1,0,0,0,0],[0,1,0,0,1,0],[0,0,0,1,0,0],[0,0,0,0,0,0]]
am4 : (Vect 8 (Vect 8  Nat))
am4 = [[0,1,1,0,0,0,0,0],[1,0,1,0,1,0,0,1],[1,1,0,1,0,0,0,0],[0,0,1,0,1,0,1,0],[0,1,0,1,0,1,1,0],[0,0,0,0,1,0,1,0],[0,0,0,1,1,1,0,0],[0,1,0,0,0,0,0,0]]

ConnectedComponents_of_am1 : List (List Nat )
ConnectedComponents_of_am1 = (ConnectedComponents am1)--[[6,5,4],[3,2,1]]

ConnectedComponents_of_am3 : List (List Nat )
ConnectedComponents_of_am3 = ConnectedComponents am3

Path_am4_2_7:Maybe  ( List Nat)
Path_am4_2_7 = (FindPath am4 2 7 )--Just ([2,1,3,4,7])

Path_am1_2_5:Maybe  ( List Nat)
Path_am1_2_5 = (FindPath am1 2 5 )--Nothing

PathProof_am4_2_7 :Maybe((List Nat),Path am4 2 7 )
PathProof_am4_2_7 = PathWithProof am4 2 7--Returns Path between 2 and 7 and a proof that it is a path.

PathProof_am1_2_5 :Maybe((List Nat),Path am1 2 5 )
PathProof_am1_2_5 = PathWithProof am1 2 5