module Gen
import Data.Fin
import Data.ZZ

%hide Prelude.Classes.(+)
%hide Prelude.Classes.(*)
%hide Prelude.Classes.(-)
%hide Prelude.Classes.(/)

%default total

-- Fin -> Nat

implicit finNat : Fin n -> Nat
finNat = finToNat

-- Fin, Nat, Integer -> ZZ

implicit finZZ : Fin n -> ZZ
finZZ = Pos . finToNat

implicit natZZ : Nat -> ZZ
natZZ = Pos

implicit integerZZ : Integer -> ZZ
integerZZ = cast

-- Fin, Nat, ZZ -> Integer

implicit zzInteger : ZZ -> Integer
zzInteger = cast

implicit natInteger : Nat -> Integer
natInteger = zzInteger . natZZ

implicit finInteger : Fin n -> Integer
finInteger = zzInteger . finZZ

-- operations

namespace NatOp
  (+) : Nat -> Nat -> Nat
  (+) = plus

  (*) : Nat -> Nat -> Nat
  (*) = mult

namespace ZZOp
  (+) : ZZ -> ZZ -> ZZ
  (+) = plusZ

  (*) : ZZ -> ZZ -> ZZ
  (*) = multZ

  (-) : ZZ -> ZZ -> ZZ
  (-) = subZ

namespace IntegerOp
  (+) : Integer -> Integer -> Integer
  (+) = prim__addBigInt

  (*) : Integer -> Integer -> Integer
  (*) = prim__mulBigInt

  (-) : Integer -> Integer -> Integer
  (-) = prim__subBigInt

-- Rationals

data Rat : Type where
  (#) : ZZ -> (y:Nat) -> {default Refl nz: isZero y = False} -> Rat

infixl 9 #

nonZeroMult : (x,y: Nat) -> isZero x = False -> isZero y = False -> isZero (mult x y) = False
nonZeroMult Z y p1 p2 = void $ trueNotFalse p1
nonZeroMult (S k) Z p1 p2 = void $ trueNotFalse p2
nonZeroMult (S k) (S j) p1 p2 = Refl

isRZero : Rat -> Bool
isRZero ((#) (Pos Z) y) = True
isRZero _ = False

rPlus : Rat -> Rat -> Rat
rPlus ((#) x y {nz=p1}) ((#) x' y' {nz=p2}) =
  (#) (x * y' + x' * y) (y * y') {nz=nonZeroMult y y' p1 p2}

rSub : Rat -> Rat -> Rat
rSub ((#) x y {nz=p1}) ((#) x' y' {nz=p2}) =
  (#) (x * y' - x' * y) (y * y') {nz=nonZeroMult y y' p1 p2}

rMult : Rat -> Rat -> Rat
rMult ((#) k j {nz=p1}) ((#) i y {nz=p2}) =
  (#) (k * i) (j * y) {nz=nonZeroMult j y p1 p2}

rDiv : Rat -> (y: Rat) -> isRZero y = False -> Rat
rDiv ((#) k j {nz=p1}) ((#) (Pos Z) y {nz=p2}) rnz = void $ trueNotFalse rnz
rDiv ((#) k j {nz=p1}) ((#) (Pos (S i)) y {nz=p2}) rnz =
  (#) (k * y) (j * (S i)) {nz=nonZeroMult j (S i) p1 Refl}
rDiv ((#) (Pos Z) j {nz=p1}) ((#) (NegS i) y {nz=p2}) rnz = 0#1
rDiv ((#) (Pos (S k)) j {nz=p1}) ((#) (NegS i) y {nz=p2}) rnz =
  (#) ((NegS k) * y) (j * (S i)) {nz=nonZeroMult j (S i) p1 Refl}
rDiv ((#) (NegS k) j {nz=p1}) ((#) (NegS i) y {nz=p2}) rnz =
  (#) ((S k) * y) (j * (S i)) {nz=nonZeroMult j (S i) p1 Refl}

-- Fin, Nat, ZZ, Integer -> Rat

implicit zzRat : ZZ -> Rat
zzRat = (# 1)

implicit integerRat : Integer -> Rat
integerRat = zzRat . integerZZ

implicit natRat : Nat -> Rat
natRat = zzRat . natZZ

implicit finRat : Fin n -> Rat
finRat = zzRat . finZZ

namespace RatOp
  (+) : Rat -> Rat -> Rat
  (+) = rPlus

  (*) : Rat -> Rat -> Rat
  (*) = rMult

  (-) : Rat -> Rat -> Rat
  (-) = rSub

  (/) : Rat -> (y: Rat) -> {default Refl nz: isRZero y = False} -> Rat
  (/) x y {nz} = rDiv x y nz


import Data.Vect

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

-- Exercise 2
reverseProof_nil : (acc : Vect n1 a) -> Vect (plus n1 0) a
reverseProof_nil {n1} acc = rewrite plusZeroRightNeutral n1 in acc

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

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


module VectHelp

import Data.Vect

%default total

||| If an element is in a concat of two vectors, then it's in one or the other.
export
elemConcat: {x: a} -> (xs: Vect m a) -> (ys: Vect n a) -> Elem x (xs ++ ys) -> Either (Elem x xs) (Elem x ys)
elemConcat {x} []        (x :: xs) Here          = Right Here
elemConcat {x} []        (y :: xs) (There later) = Right (There later)
elemConcat {x} (x :: xs) ys        Here          = Left Here
elemConcat {x} (y :: xs) ys        (There later) = case elemConcat xs ys later of
  Left l  => Left $ There l
  Right r => Right r

shift : {x : a} -> {xs : Vect len a} ->
        (y : a ** Elem y xs) -> (y : a ** Elem y (x :: xs))
shift (x ** pf) = (x ** There pf)

||| Returns all the proofs that elements of a vector are in that vector.
export
allElems: (xs: Vect n a) -> Vect n (x: a ** Elem x xs)
allElems []        = []
allElems (x :: xs) =
    let es = allElems xs
    in (x ** Here) :: (map shift es)


module CatR

%default total

{- A category is very much like a graph. It has vertices
   named objects and vertices named arrows. Each arrow goes
   from an object to an object (possibly the same!). -}
record Cat (obj: Type) (arr: obj -> obj -> Type) where
  constructor MkCat

  {- For each object, there is an arrow called `id` which
  goes from the object to itself. -}
  id: {o: obj} -> arr o o

  {- Given an arrow `f` from object `a` to `b` and an arrow
      `g` from `b` to `c`. We can compose these arrow. The
      result is an arrow from `a` to `c`. -}
  compose: {a, b, c: obj} -> arr a b -> arr b c -> arr a c

  -- Here comes some properties of `id` and `compose`

  {- For any arrow `f`, compose id f = f -}
  neutralLeft:  {a, b: obj} -> (f: arr a b) -> compose id f = f

  {- For any arrow `f`, compose f id = f  -}
  neutralRight: {a, b: obj} -> (f: arr a b) -> compose f id = f

  {- For any arrows `f`, `g` and `h`,
    composing f with g, and then the result with h
    gives exatctly the same result as
    composing f with the result of the composition of g and h

    Which means, like string concatenation than we can commpose
    the way we preserve the order of each element in the sequence.-}
  associativity: {a, b, c, d: obj} ->
                  (f: arr a b) -> (g: arr b c) -> (h: arr c d) ->
                  compose f (compose g h) = compose (compose f g) h

{- `LE n m` encode the property that `n ≤ m`
    i.e. `n` is less or equal to `m` -}
data LE : Nat -> Nat -> Type where
  LERefl : {o: Nat} -> LE o o
  LENext : {a, b: Nat} -> LE a b -> LE a (S b)

{- Taking naturals as objects and `LE` as arrows,
   this actually forms a category! -}
natPoset : Cat Nat LE
natPoset = ???


module Divisors

import ZZ
%access public export
%default total
|||isDivisible a b can be constucted if b divides a
isDivisible : ZZ -> ZZ -> Type
isDivisible a b = (n : ZZ ** a = b * n)

|||1 divides everything
oneDiv : (a : ZZ) -> isDivisible a 1
oneDiv a = (a ** rewrite sym (multOneLeftNeutralZ a) in Refl)

|||Genetes a proof of (a+b) = d*(n+m) from (a=d*n)and (b=d*m)
DistributeProof: (a:ZZ)->(b:ZZ)->(d:ZZ)->(n:ZZ)->(m:ZZ)->(a=d*n)->(b=d*m)->((a+b) = d*(n+m))
DistributeProof a b d n m pf1 pf2 = rewrite  (multDistributesOverPlusRightZ d n m) in(trans (the (a+b=(d*n)+b) (v1)) v2) where
  v1 =plusConstantRightZ a (d*n) b pf1
  v2 =plusConstantLeftZ b (d*m) (d*n) pf2

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

|||The theorem d|a and d|b =>d|(a+b)
PlusDiv : (isDivisible a d)->(isDivisible b d)->(isDivisible (a+b) d)
PlusDiv {d}{a}{b} (n**prf1) (m**prf2) = ((n+m)**(DistributeProof a b d n m prf1 prf2))
|||The theorem b|a and c|b =>c|a
TransDivide : (isDivisible a b)->(isDivisible b c)->(isDivisible a c)
TransDivide {c} (x ** pf1) (y ** pf2) = (y*x ** (rewrite  multAssociativeZ c y x in  (rewrite pf1 in (rewrite pf2 in Refl))))

|||If d divides a and b it divides a linear combination of a and b
LinCombDiv:(m:ZZ)->(n:ZZ)->(isDivisible a d)->(isDivisible b d)->(isDivisible ((a*m)+(b*n)) d)
LinCombDiv m n dDiva dDivb = PlusDiv (MultDiv  dDiva m) (MultDiv  dDivb n)

EuclidConservesDivisor:(m:ZZ)->(isDivisible a d)->(isDivisible b d)->(isDivisible (a+(b*(-m))) d)
EuclidConservesDivisor m dDiva dDivb = PlusDiv dDiva (MultDiv dDivb (-m) )

|||Any integer divides zero
ZZDividesZero:(a:ZZ)->(isDivisible 0 a )
ZZDividesZero a = (0**(sym (multZeroRightZeroZ a)))
|||A type that is occupied iff c is a common factor of a and b
isCommonFactorZ : (a:ZZ) -> (b:ZZ) -> (c:ZZ) -> Type
isCommonFactorZ a b c = ((isDivisible a c),(isDivisible b c))
|||The GCD type that is occupied iff d = gcd (a,b). Here GCD is defined as that positive integer such that any common factor of a and b divides it
GCDZ : (a:ZZ) -> (b:ZZ) -> (d:ZZ) -> Type
GCDZ a b d = ((IsPositive d),(isCommonFactorZ a b d),({c:ZZ}->(isCommonFactorZ a b c)->(isDivisible d c)))
|||Anything divides itself
SelfDivide:(a:ZZ)->(isDivisible a a)
SelfDivide a = (1**sym (multOneRightNeutralZ a))

|||Generates the proof that if c is a common factor of a and 0 then c divides a
GCDCondition : (a:ZZ) -> ({c:ZZ}->(isCommonFactorZ a 0 c)->(isDivisible a c))
GCDCondition  a {c} (cDiva,cDiv0) = cDiva
|||Proves that the GCD of a and 0 is a
gcdOfZeroAndInteger:(a:ZZ)->IsPositive a ->GCDZ a 0 a
gcdOfZeroAndInteger a pf = (pf,((SelfDivide a),(ZZDividesZero a)),((GCDCondition a)))
|||The theorem, d|a =>d|(-a)
dDividesNegative:(isDivisible a d)->(isDivisible  (-a) d)
dDividesNegative{a}{d} (x ** pf) = ((-x)**(multNegateRightIsNegateZ a d x pf))
|||The theorem c|b and c|(a+bp) then c|a
cDiva :{p:ZZ} ->(cDIvb :(isDivisible b c))->(cDIvExp:isDivisible (a+(b*p)) c)->(isDivisible a c)
cDiva {p}{b}{a}{c} cDivb cDivExp = rewrite (sym (addAndSubNeutralZ a (b*p))) in (PlusDiv cDivExp (dDividesNegative(MultDiv cDivb (p))))
|||A helper function for euclidConservesGcd function
genFunctionForGcd :(f:({c:ZZ}->(isCommonFactorZ a b c)->(isDivisible d c)))->(({c:ZZ}->(isCommonFactorZ b (a+(b*(-m)))  c)->(isDivisible d c)))
genFunctionForGcd f (cDivb,cDivExp) = f((cDiva cDivb cDivExp,cDivb))

|||The theorem, gcd(a,b)=d => gcd (b, a+ b(-m))=d
euclidConservesGcd :(m:ZZ)->(GCDZ a b d)->(GCDZ b  (a+(b*(-m))) d)
euclidConservesGcd m  (posProof, (dDiva,dDivb), f) = (posProof,(dDivb,(EuclidConservesDivisor m  dDiva dDivb)),genFunctionForGcd f)
|||The theorem that if c and d are positive d|c => (d is less than or equal to c)
posDivPosImpliesLte:(isDivisible c d)->(IsPositive c)->(IsPositive d)->LTEZ d c
posDivPosImpliesLte {d}{c}(x ** pf) cPos dPos = posLteMultPosPosEqZ {q=x} d c dPos cPos pf

|||The Theorem that if c and d are positive, d|c and c|d =>(c=d)
PosDivAndDivByImpliesEqual: (isDivisible c d)->(isDivisible d c)->(IsPositive c)->(IsPositive d) -> (c=d)
PosDivAndDivByImpliesEqual x y z x1 =lteAndGteImpliesEqualZ dLtec cLted where
  dLtec =posDivPosImpliesLte x z x1
  cLted =posDivPosImpliesLte y x1 z


module gcd

import NatUtils

%default total
%access public export

|||Auxilliary proof for euclidDivide
--Proof to finish euclidDivide, couldn't add it as a where clause within euclidDivide. If someone knows how to do that, please do so.
extendedEqualityProof : (a : Nat) -> (b : Nat) -> (q : Nat) -> (r : Nat)->
					((S r) = b) -> (a = r + (q * b)) -> (S a = (S q) * b)
extendedEqualityProof a b q r proofSmlEq proofBigEq =
	trans (cong proofBigEq) (plusConstantRight (S r) b (q * b) proofSmlEq)

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

|||Type of proof that d divides a
isDivisible : (a : Nat) -> (d : Nat) -> (Not (d = Z)) -> Type
isDivisible a d proofNotZ = (n : Nat ** a = n * d)

|||Proof that all natural numbers divide zero
zeroDivisible : {n : Nat} ->  isDivisible Z (S n) SIsNotZ
zeroDivisible {n} = (Z ** sym (multZeroLeftZero (S n)))

|||Proof that 1 divides all natural numbers
oneDivides : {n : Nat} -> isDivisible n (S Z) SIsNotZ
oneDivides {n} = (n ** rewrite multOneRightNeutral n in Refl)

|||Proof that all natural numbers divide themselves
divisionReflexive : {n : Nat} -> (isDivisible (S n) (S n) SIsNotZ)
divisionReflexive {n} = (S Z ** rewrite multOneLeftNeutral n in Refl)

|||Type of proof that d is a common divisor of a and b
isCommonDivisor : (a : Nat) -> (b : Nat) -> (d : Nat) -> (Not (d = Z)) -> Type
isCommonDivisor a b d proofNotZ = (isDivisible a d proofNotZ, isDivisible b d proofNotZ)

|||Proof that 1 is a common divisor of all pairs of natural numbers
oneCommonDivisor : {a : Nat} -> (b : Nat) -> (isCommonDivisor a b (S Z) SIsNotZ)
oneCommonDivisor {a} {b} = (oneDivides, oneDivides)

|||Proof that n is a common divisor of n and 0
zeroCommonDivisorRight : {n : Nat} -> (isCommonDivisor (S n) Z (S n) SIsNotZ)
zeroCommonDivisorRight {n} = (divisionReflexive, zeroDivisible)

|||Proof that n is a common divisor of 0 and n
zeroCommonDivisorLeft : {n : Nat} -> (isCommonDivisor Z (S n) (S n) SIsNotZ)
zeroCommonDivisorLeft {n} = (zeroDivisible, divisionReflexive)

|||Proof that a common divisor of (a, b) is a common divisor of (b, a)
commonDivisorSymmetric : {a : Nat} -> {b : Nat} -> {d : Nat} -> (isCommonDivisor a b d proofNotZ) -> (isCommonDivisor b a d proofNotZ)
commonDivisorSymmetric {a} {b} {d} (proofDividesa, proofDividesb) = (proofDividesb, proofDividesa)

|||Proof that d divides a implies d divides c * a
dividesMultiple : {a : Nat} -> {d : Nat} -> (isDivisible a d proofNotZ) -> (c : Nat)-> (isDivisible (c * a) d proofNotZ)
dividesMultiple {d} (n ** Refl) c = ((c * n) ** (rewrite (multAssociative c n d) in Refl))

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

|||Proof that d is a common divisor of a and b implies d divides a + b
dividesSum :  {a : Nat} -> {b : Nat} -> {d : Nat} -> (isCommonDivisor a b d proofNotZ)-> (isDivisible (a + b) d proofNotZ)
dividesSum {a} {b} {d} ((m ** proofDividesa), (n ** proofDividesb)) =
	((m + n) ** (distributeProof a b d m n proofDividesa proofDividesb))

|||Proof d divides a and a = b implies d divides b
eqConservesDivisible : {a : Nat} -> {b : Nat} -> {d : Nat} -> {proofNotZ : Not (d = Z)} ->
					(isDivisible a d proofNotZ) -> (a = b) -> (isDivisible b d proofNotZ)
eqConservesDivisible {a} {d} (n ** proofDivides) Refl = (n ** proofDivides)

|||Proof that d is a common divisor of a and b implies d divides a * x + b * y
dividesLinearCombination :  {a : Nat} -> {b : Nat} -> {d : Nat} -> {proofNotZ : Not (d = Z)} ->
						(isCommonDivisor a b d proofNotZ) -> (x : Nat) -> (y : Nat) ->
						(isDivisible ((x * a) + (y * b)) d proofNotZ)
dividesLinearCombination {proofNotZ = prf} commonDivisorProof x y =
	dividesSum {proofNotZ = prf} ((dividesMultiple {proofNotZ = prf} (fst commonDivisorProof) x), (dividesMultiple {proofNotZ = prf} (snd commonDivisorProof) y))


module Test.Spec

import Specdris.Spec
import Data.Functor.Foldable
import Data.Vect
import Control.Comonad.Cofree

-- FIXME morphisms with constraints? particularly re: symmteries
-- "safe" compilation using this?
-- particularly discrete pseudo-hamiltonian dynamics
-- oh man finite symplectic geometry

-- TODO computation of pi from http://www.cs.ox.ac.uk/jeremy.gibbons/publications/metamorphisms-mpc.pdf

naturals : Nat -> ListF Nat Nat
naturals Z = NilF
naturals (S n) = Cons (n + 1) n

-- This is also an instructive use of cofree comonads!
-- Do note that it indexes starting at 0.
catalan : Nat -> Nat
catalan = dyna coalgebra naturals
  where
    coalgebra : ListF Nat (Cofree (ListF Nat) Nat) -> Nat
    coalgebra NilF = 1
    coalgebra (Cons n table) = sum (Prelude.List.zipWith (*) xs (reverse xs))
      where
        xs = take n table
        take : Nat -> (Cofree (ListF Nat) Nat) -> List Nat
        take Z _ = []
        take (S n) (Co a NilF) = [a]
        take (S n) (Co a (Cons v as)) = a :: take n as

roundedSqrt : Nat -> Nat
roundedSqrt = cast . cast {to=Integer} . sqrt . cast

toN : Nat -> List Nat
toN = reverse . ana naturals

isPrime : Nat -> List Nat -> Bool
isPrime n ns = all (\a => mod n a /= 0) (filter (<= (roundedSqrt n)) ns)

dedup : (Eq a) => List a -> List a
dedup = para pseudoalgebra where
  pseudoalgebra : (Eq a) => ListF a (List a, List a) -> List a
  pseudoalgebra NilF                 = []
  pseudoalgebra (Cons x (past, xs))  = if elem x past then xs else x :: xs

evenOdd : Nat -> Bool
evenOdd = mutu odd even where
  odd : Maybe (Bool, Bool) -> Bool
  odd Nothing = False
  odd (Just (_, b)) = b
  even : Maybe (Bool, Bool) -> Bool
  even Nothing = True
  even (Just (_, b)) = b

collatzCoalgebra : Int -> Either (List Int) (ListF Int Int)
collatzCoalgebra 1 = Left [1]
collatzCoalgebra 2 = Left [2, 1]
collatzCoalgebra 3 = Left [3, 10, 5, 16, 8, 4, 2, 1]
collatzCoalgebra 4 = Left [6, 3, 10, 5, 16, 8, 4, 2, 1]
collatzCoalgebra n with (modInt n 2)
  | 0 = Right $ Cons n (divInt n 2)
  | _ = Right $ Cons n (3 * n + 1)

collatz : Int -> List Int
collatz = micro collatzCoalgebra

elgotCoalgebra : List a -> Either (List (List a)) (ListF (List a) (List a))
elgotCoalgebra [] = Right NilF
elgotCoalgebra (x :: []) = Left ([[x]])
elgotCoalgebra (x :: xs) = Right (Cons (x :: xs) xs)

-- fibonacci zygomorphism?

zygoPseudoalgebra : ListF Int (Bool, Int) -> Int
zygoPseudoalgebra NilF = 0
zygoPseudoalgebra (Cons n (b, x)) = if b then (n+x) else (n-x)

zygoAlgebra : ListF Int Bool -> Bool
zygoAlgebra NilF = False
zygoAlgebra (Cons _ bool) = not bool

plusMinus : List Int -> Int
plusMinus = zygo zygoAlgebra zygoPseudoalgebra

algebra' : ListF (List a) (List a) -> List a
algebra' NilF = []
algebra' (Cons x xs) = x ++ xs

cataConcat : List (List a) -> List a
cataConcat = cata algebra'

algebra : ListF (List a) (List (List a)) ->  List (List a)
algebra NilF = []
algebra (Cons x xs) = x::xs

coalgebra : List a -> ListF (List a) (List a)
coalgebra (x::xs) = Cons (x::xs) xs
coalgebra [] = NilF

suffix : List a -> List (List a)
suffix = hylo algebra coalgebra . drop 1

export
specSuite : IO ()
specSuite =
  spec $ do
    describe "hylo" $
      it "should be able to implement the suffix function" $
        (suffix . unpack) "ego" `shouldBe` [['g','o'], ['o']]
    describe "cata" $
      it "should be able to implement 'concat'" $
      (cataConcat . map unpack) [ "I", "am" ] `shouldBe` ['I', 'a', 'm']
    describe "zygo" $
      it "should be able to implement plusMinus" $
        plusMinus [1,2,3] `shouldBe` -4
    describe "micro" $
      it "should provide a simple way to compute the Collatz sequence associated with a number" $
        collatz 12 `shouldBe` [12, 6, 3, 10, 5, 16, 8, 4, 2, 1]
    describe "mutu" $
      it "should be able to do recursion on the natural numbers to check for parity" $
        (evenOdd . fromIntegerNat) 10 `shouldBe` True
    describe "para" $
      it "should provide an elegant way to remove duplicates from a list when order doesn't matter" $
        dedup [1,1,2,3,4,5,4] `shouldBe` [1,2,3,5,4]
    describe "dyna" $
      it "should do something with catalan numbers" $
        catalan 6 `shouldBe` 132
    describe "ana" $
      it "should give the first n naturals" $
        toN 5 `shouldBe` [1,2,3,4,5]


module NatOrder

import NatUtils

%default total
%access public export

|||New type for <= on Nat
LEQ : (a : Nat) -> (b : Nat) -> Type
LEQ a b = (k : Nat ** ((a + k) = b))

|||New type for >= on Nat
GEQ : (a : Nat) -> (b : Nat) -> Type
GEQ a b = LEQ b a

|||New type for < on Nat
LNEQ : (a : Nat) -> (b : Nat) -> Type
LNEQ a b = (LEQ a b, Not (a = b))

|||New type for > on Nat
GNEQ : (a : Nat) -> (b : Nat) -> Type
GNEQ a b = LNEQ b a

|||Proof that 0 is the smallest natural number
LEQZero : {n : Nat} -> LEQ Z n
LEQZero {n} = (n ** Refl)

|||Proof that 0 is lesser than every successor
LNEQZeroSucc : {n : Nat} -> LNEQ Z (S n)
LNEQZeroSucc {n} = (((S n) ** Refl), ZIsNotS)

|||Proof that a <= b implies (S a) <= (S b)
LEQSucc : {a : Nat} -> {b : Nat} -> (LEQ a b) -> (LEQ (S a) (S b))
LEQSucc {a} {b} (k ** proofEq) = (k ** cong proofEq)

|||Proof that a < b implies (S a) < (S b)
LNEQSucc : {a : Nat} -> {b : Nat} -> (LNEQ a b) -> (LNEQ (S a) (S b))
LNEQSucc {a} {b} ((k ** proofEq), proofNotEq) = ((k ** cong proofEq), proofNotEqSucc proofNotEq) where
	proofNotEqSucc : (Not (a = b)) -> (Not (S a = S b))
	proofNotEqSucc proofNotEq proofEq = proofNotEq (predEqual proofEq)

|||Proof that (S a) <= (S b) implies a <= b
LEQPred : {a : Nat} -> {b : Nat} -> (LEQ (S a) (S b)) -> (LEQ a b)
LEQPred {a} {b} (k ** proofEq) = (k ** predEqual proofEq)

|||Proof that (S a) < (S b) implies a < b
LNEQPred : {a : Nat} -> {b : Nat} -> (LNEQ (S a) (S b)) -> (LNEQ a b)
LNEQPred {a} {b} ((k ** proofEq), proofNotEq) = ((k ** predEqual proofEq), proofNotEqPred proofNotEq) where
	proofNotEqPred : (Not (S a = S b)) -> (Not (a = b))
	proofNotEqPred proofNotEq proofEq = proofNotEq (cong proofEq)

|||Proof that !(a <= b) implies !((S a) <= (S b))
notLEQSucc : {a : Nat} -> {b : Nat} -> (Not (LEQ a b)) -> (Not (LEQ (S a) (S b)))
notLEQSucc {a} {b} proofNotLEQ proofLEQ = proofNotLEQ (LEQPred proofLEQ)

|||Proof that !((S a) <= (S b)) implies !(a <= b)
notLEQPred : {a : Nat} -> {b : Nat} ->  (Not (LEQ (S a) (S b))) -> (Not (LEQ a b))
notLEQPred {a} {b} proofNotLEQ proofLEQ = proofNotLEQ (LEQSucc proofLEQ)

|||Proof that !(a < b) implies !((S a) < (S b))
notLNEQSucc : {a : Nat} -> {b : Nat} -> (Not (LNEQ a b)) -> (Not (LNEQ (S a) (S b)))
notLNEQSucc {a} {b} proofNotLNEQ proofLNEQ = proofNotLNEQ (LNEQPred proofLNEQ)

|||Proof that !((S a) < (S b)) implies !(a < b)
notLNEQPred : {a : Nat} -> {b : Nat} ->  (Not (LNEQ (S a) (S b))) -> (Not (LNEQ a b))
notLNEQPred {a} {b} proofNotLNEQ proofLNEQ = proofNotLNEQ (LNEQSucc proofLNEQ)

|||Proof that !(a < = b) implies b < a
notLEQImpliesGNEQ : {a : Nat} -> {b : Nat} -> (Not (LEQ a b)) -> (GNEQ a b)
notLEQImpliesGNEQ {a = Z} {b} proofNotLEQ = void (proofNotLEQ (b ** Refl))
notLEQImpliesGNEQ {a = (S n)} {b = Z} _ = ((S n ** Refl), ZIsNotS)
notLEQImpliesGNEQ {a = (S n)} {b = (S m)} proofNotLEQ = (LEQSucc proofGEQ, notEqualSucc proofNotEq) where
	proofGEQ = fst (notLEQImpliesGNEQ {a = n} {b = m} (notLEQPred proofNotLEQ))
	proofNotEq = snd (notLEQImpliesGNEQ {a = n} {b = m} (notLEQPred proofNotLEQ))

|||Proof that !(a < b) implies b <= a
notLNEQImpliesGEQ : {a : Nat} -> {b : Nat} -> (Not (LNEQ a b)) -> (GEQ a b)
notLNEQImpliesGEQ {a} {b = Z} _ = (a ** Refl)
notLNEQImpliesGEQ {a = Z} {b = (S m)} proofNotLNEQ = void (proofNotLNEQ (((S m) ** Refl), ZIsNotS))
notLNEQImpliesGEQ {a = (S n)} {b = (S m)} proofNotLNEQ = (LEQSucc proofGEQ) where
	proofGEQ = notLNEQImpliesGEQ {a = n} {b = m} (notLNEQPred proofNotLNEQ)

|||decides if a <= b
isLEQ : (a : Nat) -> (b : Nat) -> Dec (LEQ a b)
isLEQ Z b = Yes (b ** Refl)
isLEQ (S a) Z = No (\(k ** proofEq) => (SIsNotZ proofEq))
isLEQ (S a) (S b) with (isLEQ a b)
	isLEQ (S a) (S b) | (Yes proofLEQ) = Yes (LEQSucc proofLEQ)
	isLEQ (S a) (S b) | (No contra) = No (\(k ** proofEq) => (contra (k ** (predEqual proofEq))))

|||Proof that a <= b implies a = b or a < b
leqImpliesEqOrLNEQ : {a : Nat} -> {b : Nat} -> (LEQ a b) -> Either (a = b) (LNEQ a b)
leqImpliesEqOrLNEQ {a} {b} (k ** proofEq) = case k of
	Z => Left (rewrite (plusCommutative Z a) in proofEq)
	(S n) => Right (((S n) ** proofEq), nonZeroSumNotEqual proofEq SIsNotZ)

|||Proof that all successors are larger than 0
succNotLEQzero : {n : Nat} -> (Not (LEQ (S n) Z))
succNotLEQzero {n} = \(k ** proofEq) => (SIsNotZ proofEq)

|||Proof that LEQ is reflexive
leqRefl : {n : Nat} -> LEQ n n
leqRefl {n} = (Z ** plusZeroRightNeutral n)

|||Proof that (a + k = b) and (b + l = a) implies (k = 0) and (l = 0)
leqAntiSymmetricIndirect : {a : Nat} -> {b : Nat} ->
						(proofLEQLeft : (LEQ a b)) -> (proofLEQRight : (LEQ b a)) ->
						((fst proofLEQLeft) = Z, (fst proofLEQRight) = Z)
leqAntiSymmetricIndirect {a} {b} (k ** proofEqLeft) (l ** proofEqRight) =
	sumZeroImpliesZero (plusLeftCancel a (k + l) Z inductionStep) where
	inductionStep = rewrite (plusAssociative a Z (k + l)) in
					rewrite (plusZeroRightNeutral a) in
					rewrite (plusAssociative a k l) in
					trans (cong {f = (\n => n + l)} proofEqLeft) proofEqRight

|||Proof that LEQ is antisymmetric
leqAntiSymmetric : {a : Nat} -> {b : Nat} -> (LEQ a b) -> (LEQ b a) -> (a = b)
leqAntiSymmetric {a} {b} (k ** proofEqLeft) (l ** proofEqRight) =
	rewrite (plusCommutative Z a) in
	rewrite (sym (fst (leqAntiSymmetricIndirect {a} {b} (k ** proofEqLeft) (l ** proofEqRight)))) in proofEqLeft

|||Proof that LEQ is transitive
leqTransitive : {a : Nat} -> {b : Nat} -> {c : Nat} -> (LEQ a b) -> (LEQ b c) -> (LEQ a c)
leqTransitive {a} {b} {c} (k ** proofEqLeft) (l ** proofEqRight) = ((k + l) ** proofEq) where
	proofEq = rewrite (plusAssociative a k l) in
			trans (cong {f = (\n => n + l)} proofEqLeft) (proofEqRight)

|||Proof that a <= b implies a <= b + c
leqPlusRight : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LEQ a b) -> (LEQ a (b + c))
leqPlusRight {a} {b} c (k ** proofEq) = ((k + c) ** rewrite (plusAssociative a k c) in (cong {f = (\n => (n + c))} proofEq))

|||Proof that a + c <= b implies a <= b
ltePlusLeft : {a : Nat} -> {b : Nat} -> {c : Nat} -> (LEQ (a + c) b) -> (LEQ a b)
ltePlusLeft {a} {b} {c} (k ** proofEq) = ((c + k) ** rewrite (plusAssociative a c k) in proofEq)

|||Proof that a <= b implies (c + a) <= (c + b)
leqPlusConstantLeft : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LEQ a b) -> (LEQ (c + a) (c + b))
leqPlusConstantLeft {a} {b} c (k ** proofEq) = (k ** proofFinalEq) where
	proofFinalEq = rewrite (sym (plusAssociative c a k)) in (cong {f = (\n => c + n)} proofEq)

|||Proof that a <= b implies (a + c) <= (b + c)
leqPlusConstantRight : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LEQ a b) -> (LEQ (a + c) (b + c))
leqPlusConstantRight {a} {b} c proofLEQ = rewrite (plusCommutative a c) in
									rewrite (plusCommutative b c) in
									(leqPlusConstantLeft c proofLEQ)

|||Proof that (c + a) <= (c + b) implies a <= b
leqMinusConstantLeft : {a : Nat} -> {b : Nat} -> {c : Nat} -> (LEQ (c + a) (c + b)) -> (LEQ a b)
leqMinusConstantLeft {a} {b} {c} (k ** proofEq) = (k ** proofFinalEq) where
	proofFinalEq = (plusLeftCancel c (a + k) b (rewrite (plusAssociative c a k) in proofEq))

|||Proof that (a + c) <= (b + c) implies a <= b
leqMinusConstantRight : {a : Nat} -> {b : Nat} -> {c : Nat} -> (LEQ (a + c) (b + c)) -> (LEQ a b)
leqMinusConstantRight {a} {b} {c} proofLEQ = leqMinusConstantLeft {a} {b} {c} proofFinalEq where
	proofFinalEq = rewrite (plusCommutative c a) in
				rewrite (plusCommutative c b) in proofLEQ

|||Proof that if a <= b, and c <= d, then (a + c) <= (b + d)
leqPlusIsLEQ : {a : Nat} -> {b : Nat} -> {c : Nat} -> {d : Nat} ->
			(LEQ a b) -> (LEQ c d) -> (LEQ (a + c) (b + d))
leqPlusIsLEQ {a = a0} {b = b0} {c = c0} {d = d0} proofLeftLEQ proofRightLEQ =
	leqTransitive (leqPlusConstantRight {a = a0} {b = b0} c0 proofLeftLEQ) (leqPlusConstantLeft {a = c0} {b = d0} b0 proofRightLEQ)

|||Proof that a <= b implies (c * a) <= (c * b)
leqMultConstantLeft : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LEQ a b) -> (LEQ (c * a) (c * b))
leqMultConstantLeft {a} {b} c (k ** proofEq) = ((c * k) ** proofFinalEq) where
	proofFinalEq = rewrite (sym (multDistributesOverPlusRight c a k)) in
				cong {f = (\n => c * n)} proofEq

|||Proof that a <= b implies (a * c) <= (b * c)
leqMultConstantRight : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LEQ a b) -> (LEQ (a * c) (b * c))
leqMultConstantRight {a} {b} c (k ** proofEq) = ((k * c) ** proofFinalEq) where
	proofFinalEq = rewrite (sym (multDistributesOverPlusLeft a k c)) in
				cong {f = (\n => n * c)} proofEq

|||Proof that if a <= b, and c <= d, then (a * c) <= (b * d)
leqMultIsLEQ : {a : Nat} -> {b : Nat} -> {c : Nat} -> {d : Nat} ->
			(LEQ a b) -> (LEQ c d) -> (LEQ (a * c) (b * d))
leqMultIsLEQ {a = a0} {b = b0} {c = c0} {d = d0} proofLeftLEQ proofRightLEQ =
	leqTransitive (leqMultConstantRight {a = a0} {b = b0} c0 proofLeftLEQ) (leqMultConstantLeft {a = c0} {b = d0} b0 proofRightLEQ)

|||Proof that (c * a) <= (c * b) and c != 0 implies a <= b
leqDivConstantLeft : {a : Nat} -> {b : Nat} -> {c : Nat} -> (Not (c = Z)) ->
					(LEQ (c * a) (c * b)) -> (LEQ a b)
--To be proved

|||Proof that (a * c) <= (b * c) and c != 0 implies a <= b
leqDivConstantRight : {a : Nat} -> {b : Nat} -> {c : Nat} -> (Not (c = Z)) ->
					(LEQ (a * c) (b * c)) -> (LEQ a b)
--To be proved

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

|||Convert from LEQ to LTE
leqToLTE : {a : Nat} -> {b : Nat} -> (LEQ a b) -> (LTE a b)
leqToLTE {a = Z} {b} _ = LTEZero
leqToLTE {a = S m} {b = Z} proofLEQ = void(succNotLEQzero proofLEQ)
leqToLTE {a = S m} {b = S n} (k ** proofEq) = LTESucc (leqToLTE {a = m} {b = n} (k ** predEqual proofEq))

|||Convert from LTE to LEQ
lteToLEQ : {a : Nat} -> {b : Nat} -> (LTE a b) -> (LEQ a b)
lteToLEQ {a = Z} {b} _ = LEQZero
lteToLEQ {a = S m} {b = Z} proofLTE = void(succNotLTEzero proofLTE)
lteToLEQ {a = S m} {b = S n} (LTESucc proofLTE) = LEQSucc (lteToLEQ {a = m} {b = n} proofLTE)

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


import Data.Vect
import Data.Nat

my_filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)
my_filter p [] = ( _ ** [] )
my_filter p (x :: xs) with (filter p xs)
  my_filter p (x :: xs) | ( _ ** xs' ) = if (p x) then ( _ ** x :: xs' ) else ( _ ** xs' )

foo : Int -> Int -> Bool
foo n m with (n + 1)
  foo _ m | 2 with (m + 1)
    foo _ _ | 2 | 3 = True
    foo _ _ | 2 | _ = False
  foo _ _ | _ = False

data Parity : Nat -> Type where
     Even : {n : _} -> Parity (n + n)
     Odd  : {n : _} ->Parity (S (n + n))

-- parity : (n : Nat) -> Parity n
-- parity Z = Even {n = Z}
-- parity (S Z) = Odd {n = Z}
-- parity (S (S k)) with (parity k)
--   parity (S (S (j + j))) | Even
--       = rewrite plusSuccRightSucc j j in Even {n = S j}
--   parity (S (S (S (j + j)))) | Odd
--       = rewrite plusSuccRightSucc j j in Odd {n = S j}

helpEven : (j : Nat) -> Parity (S j + S j) -> Parity (S (S (plus j j)))
helpEven j p = rewrite plusSuccRightSucc j j in p

helpOdd : (j : Nat) -> Parity (S (S (j + S j))) -> Parity (S (S (S (j + j))))
helpOdd j p = rewrite plusSuccRightSucc j j in p

parity : (n:Nat) -> Parity n
parity Z     = Even {n=Z}
parity (S Z) = Odd {n=Z}
parity (S (S k)) with (parity k)
  parity (S (S (j + j)))     | Even = helpEven j (Even {n = S j})
  parity (S (S (S (j + j)))) | Odd  = helpOdd j (Odd {n = S j})

natToBin : Nat -> List Bool
natToBin Z = Nil
natToBin k with (parity k)
   natToBin (j + j)     | Even = False :: natToBin j
   natToBin (S (j + j)) | Odd  = True  :: natToBin j


module Main

-- base
import Data.Nat

record InputData where
  constructor MkInputData
  publicKeyCard : Nat
  publicKeyDoor : Nat

inputData : InputData
inputData = MkInputData 5290733 15231938

namespace Part1
  transformSubjectNumberStep : (subjectNumber : Integer) -> (value : Integer) -> Integer
  transformSubjectNumberStep subjectNumber value = (subjectNumber * value) `mod` 20201227

  export
  loopSize : (publicKeyCard : Nat) -> (subjectNumber : Nat) -> Nat
  loopSize publicKey subjectNumber = try 1 where
    publicKey' : Integer
    publicKey' = natToInteger publicKey
    subjectNumber' : Integer
    subjectNumber' = natToInteger subjectNumber
    try : (value : Integer) -> Nat
    try value = if publicKey' == value
                   then Z
                   else S $ try $ transformSubjectNumberStep subjectNumber' value

  transformSubjectNumber' : (loopSize : Nat) -> (subjectNumber : Integer) -> (value : Integer) -> Integer
  transformSubjectNumber' Z subjectNumber value = value
  transformSubjectNumber' (S k) subjectNumber value =
    transformSubjectNumber' k subjectNumber $ transformSubjectNumberStep subjectNumber value

  export
  transformSubjectNumber : (loopSize : Nat) -> (subjectNumber : Nat) -> Nat
  transformSubjectNumber loopSize subjectNumber =
    integerToNat $ transformSubjectNumber' loopSize (natToInteger subjectNumber) 1

loopSizeCard : Nat
loopSizeCard = loopSize inputData.publicKeyCard 7

encryptionKey1 : Nat
encryptionKey1 = transformSubjectNumber loopSizeCard inputData.publicKeyDoor

loopSizeDoor : Nat
loopSizeDoor = loopSize inputData.publicKeyDoor 7

encryptionKey2 : Nat
encryptionKey2 = transformSubjectNumber loopSizeDoor inputData.publicKeyCard

main : IO ()
main = do
  putStrLn . show $ encryptionKey1
  putStrLn . show $ encryptionKey2
  pure ()


||| Implementation of ordering relations for `Nat`ural numbers
module Data.Nat.Order

import Control.Relation
import Data.Nat
import Data.Fun
import Data.Rel
import Decidable.Decidable
import Decidable.Equality

%default total

public export
zeroNeverGreater : Not (LTE (S n) Z)
zeroNeverGreater LTEZero     impossible
zeroNeverGreater (LTESucc _) impossible

public export
zeroAlwaysSmaller : {n : Nat} -> LTE Z n
zeroAlwaysSmaller = LTEZero

public export
ltesuccinjective : {0 n, m : Nat} -> Not (LTE n m) -> Not (LTE (S n) (S m))
ltesuccinjective disprf (LTESucc nLTEm) = void (disprf nLTEm)
ltesuccinjective disprf LTEZero         impossible

public export
decideLTE : (n : Nat) -> (m : Nat) -> Dec (LTE n m)
decideLTE    Z      y  = Yes LTEZero
decideLTE (S x)     Z  = No  zeroNeverGreater
decideLTE (S x)   (S y) with (decEq (S x) (S y))
  decideLTE (S x)   (S y) | Yes eq      = rewrite eq in Yes (reflexive {rel = LTE})
  decideLTE (S x)   (S y) | No _ with (decideLTE x y)
    decideLTE (S x)   (S y) | No _   | Yes nLTEm = Yes (LTESucc nLTEm)
    decideLTE (S x)   (S y) | No _   | No  nGTm  = No (ltesuccinjective nGTm)

public export
Decidable 2 [Nat,Nat] LTE where
  decide = decideLTE

public export
Decidable 2 [Nat,Nat] LT where
  decide m = decideLTE (S m)

public export
lte : (m : Nat) -> (n : Nat) -> Dec (LTE m n)
lte m n = decide {ts = [Nat,Nat]} {p = LTE} m n

public export
shift : (m : Nat) -> (n : Nat) -> LTE m n -> LTE (S m) (S n)
shift m n mLTEn = LTESucc mLTEn


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


||| Helper functions to work with `Data.Bits`.

module Patricia.BitsUtils

import Data.Bits
import Data.Fin

%default total
%access public export

||| Checks if bit at index `i` is set to `0`.
isZeroBit : Fin n -> Bits n -> Bool
isZeroBit i b = not $ getBit i b

||| Sets the indicated bit to zero and all the lesser bits to one.
|||
||| @i Index of bit to set.
||| @b Target bits.
maskInsignificant : (i : Fin n) -> (b : Bits n) -> Bits n
maskInsignificant i b = and (b `or` minus m (cast 1)) (complement m) where
    m : Bits n
    m = intToBits $ pow 2 (finToNat i)  -- TODO: implement more efficiently?

||| Checks if bits key before _branching bit_ matches _prefix_ bits.
|||
||| @i Index of branching bit.
||| @p Prefix bits.
||| @k Key bits.
matchPrefix : (i : Fin n) -> (p : Bits n) -> (k : Bits n) -> Bool
matchPrefix i p k = maskInsignificant i k == p

{-
    // Fast Imperative implementation for 32bits

>>> public static int highestOneBit(int i) {
>>>     i |= (i >>  1);
>>>     i |= (i >>  2);
>>>     i |= (i >>  4);
>>>     i |= (i >>  8);
>>>     i |= (i >> 16);
>>>     return i - (i >>> 1);
>>> }
-}

-- TODO: make it truely total
--   1. Ensure bits value under `b` is not zero
--   2. Ensure `natToFin` returns `Just` (use `fromInteger`?)
--   3. Ensure `shiftGo` returns not zero bits
-- TODO: make it fast
--   1. ¯\_(ツ)_/¯
||| Returns index of highest one bit set in `b`.
highestOneBit : Bits (S n) -> Fin (S n)  -- TODO: support Bits n -> Fin n ?
highestOneBit {n} b = bitsToFin $ shiftGo iterations b oneBit where
    iterations : Nat
    iterations = log2NZ (S n) SIsNotZ

    oneBit : Bits (S n)
    oneBit = cast 1

    shiftGo : Nat -> Bits (S n) -> Bits (S n) -> Bits (S n)
    shiftGo Z     i p = i `minus` (i `shiftRightLogical` oneBit)
    shiftGo (S k) i p = shiftGo k (i `or` (i `shiftRightArithmetic` p)) (p `shiftLeft` oneBit)

    bitsToFin : Bits (S n) -> Fin (S n)
    bitsToFin bits = fromMaybe FZ $ natToFin (log2NZ (toNat $ bitsToInt bits) believe_me) (S n)

branchingBit : Bits (S n) -> Bits (S n) -> Fin (S n)
branchingBit p0 p1 = highestOneBit $ xor p0 p1


nth_error : (l : List Nat) -> (n : Nat) -> Maybe Nat
nth_error [] n = Nothing
nth_error (x :: xs) n =
    case n == 0 of
        True => Just x
        False => nth_error xs (pred n)

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

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

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

option_elim : (default : Nat) -> (o : Maybe Nat) -> Nat
option_elim default Nothing = default
option_elim default (Just x) = x

hd_error : (l : List Nat) -> Maybe Nat
hd_error [] = Nothing
hd_error (x :: xs) = Just x

test_hd_error1 : hd_error [] = Nothing
test_hd_error1 = Refl

test_hd_error2 : hd_error [1] = Just 1
test_hd_error2 = Refl

test_hd_error3 : hd_error [5, 6] = Just 5
test_hd_error3 = Refl

hd : (default : Nat) -> (l : List Nat) -> Nat
hd default [] = default
hd default (x :: xs) = x

option_elim_hd : (l : List Nat) -> (default : Nat) -> hd default l = option_elim default (hd_error l)
option_elim_hd [] default = Refl
option_elim_hd (x :: xs) default = Refl


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)