> module SequentialDecisionProblems.TabBackwardsInduction

> import Data.Vect
> import Control.Isomorphism

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.Utils

> import Nat.Operations
> import Nat.OperationsProperties
> import Nat.LTEProperties
> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Decidable.Properties
> import Sigma.Sigma
> import Sigma.Operations
> import Pairs.Operations
> import Vect.Operations
> import Vect.Properties
> import Decidable.Predicates
> import Fin.Operations

> %default total
> %access public export
> %auto_implicits off

* Preliminaries

The major disadvantage of the generic backwards induction implementation
of the core theory

< bi : (t : Nat) -> (n : Nat) -> PolicySeq t n
< bi t  Z     =  Nil
< bi t (S n)  =  optExt ps :: ps where
<   ps : PolicySeq (S t) n
<   ps = bi (S t) n

is that its computational cost is exponential in the number of decidion
steps. Consider, for example, |bi 0 3|

< bi 0 3
<   = { def. |bi| }
< (optExt (bi 1 2)) :: (bi 1 2)
<   = { def. |bi| }
< (optExt ((optExt (bi 2 1)) :: (bi 2 1))) :: (optExt (bi 2 1)) :: (bi 2 1)
<   = { def. |bi| }
< (optExt ((optExt ((optExt (bi 3 0)) :: (bi 3 0))) :: (optExt (bi 3 0)) :: (bi 3 0))) ::
< (optExt ((optExt (bi 3 0)) :: (bi 3 0))) ::
< (optExt (bi 3 0)) ::
< (bi 3 0)
<   = { def. |bi| }
< (optExt ((optExt ((optExt Nil) :: Nil)) :: (optExt Nil) :: Nil)) ::
< (optExt ((optExt Nil) :: Nil)) ::
< (optExt Nil) ::
< Nil

resulting in

- 4 computations of |optExt Nil|
- 2 computations of |optExt ((optExt Nil) :: Nil)|
- 1 computation of |optExt ((optExt ((optExt Nil) :: Nil)) :: ((optExt Nil) :: Nil))|

or 7 calls to |optExt|. One more decision step implies 15 calls to
|optExt| suggesting that the number of calls to |optExt| for |n|
decision steps is |sum_{i = 0}^{n - 1} 2^j = (1 - 2^n) / (1 - 2)|.

* Towards a tail-recursive implementation

We can make the number of calls to |optExt| linear in |n| by rewriting
|bi| in tail-recursive form. The first step is to replace the recursive
call to |bi| with an iteration. Instead of pattern matching on the
number of steps, we delegate the computation of the policy sequence to
an auxiliary function |ibi| which implements backwards induction
iteratively:

> ||| Iterative backwards induction
> ibi : (t : Nat) -> (n : Nat) -> (c : Nat) -> LTE c n ->
>       PolicySeq (n - c + t) c -> PolicySeq t n
> ibi t n c prf ps with (n - c) proof itsEqual
>   |  Z    = replace {P = \ x => PolicySeq (Z + t) x} ceqn
>             ps where
>       ceqn : c = n
>       ceqn = minusLemma3 prf itsEqual
>   | (S m) = assert_total (ibi t n (S c) prf' ps') where
>       prf' : LTE (S c) n
>       prf' = minusLemma2 prf (sym itsEqual)
>       ps'  : PolicySeq (n - (S c) + t) (S c)
>       ps'  = replace {P = \ x => PolicySeq (x + t) (S c)} (minusLemma1 (sym itsEqual))
>              ((optExt ps) :: ps)

> ||| Tail-recursive backwardsinduction
> trbi : (t : Nat) -> (n : Nat) -> PolicySeq t n
> trbi t n = ibi t n Z LTEZero Nil

We can check that |trbi 0 3| and |bi 0 3| reduce to the same expression

< trbi 0 3
<   = { def. |trbi| }
< ibi 0 3 0 LTEZero Nil
<   = { def. |ibi| }
< ibi 0 3 1 (...) (optExt Nil) ::
<                 Nil
<   = {def. |ibi|}
< ibi 0 3 2 (...) (optExt ((optExt Nil) :: Nil)) ::
<                 (optExt Nil) ::
<                 Nil
<   = {def. |ibi|}
< ibi 0 3 3 (...) (optExt ((optExt ((optExt Nil) :: Nil)) :: (optExt Nil) :: Nil)) ::
<                 (optExt ((optExt Nil) :: Nil)) ::
<                 (optExt Nil) ::
<                 Nil
<   = {def. |ibi|}
< (optExt ((optExt ((optExt Nil) :: Nil)) :: (optExt Nil) :: Nil)) ::
< (optExt ((optExt Nil) :: Nil)) ::
< (optExt Nil) ::
< Nil

* Tabulation

If the state space is finite

> finiteState : (t : Nat) -> Finite (State t)

, we can compute the number of values of type |State t| and collect them
in a vector

> cardState : (t : Nat) -> Nat
> cardState t = card (finiteState t)

> vectState : (t : Nat) -> Vect (cardState t) (State t)
> vectState t = toVect (finiteState t)

If |Reachable| and |Viable n| are also decidable

> decidableReachable : {t' : Nat} -> (x' : State t') -> Dec (Reachable x')

< decidableViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Dec (Viable n x)

then their conjunction

> ReachableAndViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Type
> ReachableAndViable n x = (Reachable x , Viable n x)

is decidable

> decidableReachableAndViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Dec (ReachableAndViable n x)
> decidableReachableAndViable n x = decPair (decidableReachable x) (decidableViable n x)

and we can collect all states which are reachable and viable in a vector:

> cardReachableAndViableState : (t : Nat) -> (n : Nat) -> Nat
> cardReachableAndViableState t n = outl (f t n) where
>   f : (t : Nat) -> (n : Nat) -> Sigma Nat (\ m => Vect m (Sigma (State t) (ReachableAndViable n)))
>   f t n = filterTagSigma (decidableReachableAndViable n) (vectState t)

> vectReachableAndViableState : (t : Nat) -> (n : Nat) ->
>                               Vect (cardReachableAndViableState t n) (Sigma (State t) (ReachableAndViable n))
> vectReachableAndViableState t n = outr (f t n) where
>   f : (t : Nat) -> (n : Nat) -> Sigma Nat (\ m => Vect m (Sigma (State t) (ReachableAndViable n)))
>   f t n = filterTagSigma (decidableReachableAndViable n) (vectState t)

In this case, we can implement a "tabulated" versions of |bi| which is
linear in the number of decidion steps. Remember that |optExt| takes a
policy sequence for |n| steps and computes a policy sequence for |n + 1|
steps:

< optExt : {t, n : Nat} ->
<          (ps : PolicySeq (S t) n) -> Policy t (S n)

The idea is to replace the |ps| argument of |optExt| with a "value
table" |vt : Vect (cardReachableAndViableState t n) Val| storing the
value, for every state in |vectReachableAndViableState (S t) n|, of
taking |n| decision steps with |ps| starting from that state:

> toptExt : {t, n : Nat} ->
>           (vt : Vect (cardReachableAndViableState (S t) n) Val) -> Policy t (S n)

We implement |toptExt| on the basis of the implementation of |optExt|
of the core theory. We start with a tabulated version of |sval|:

> tsval : {t,n : Nat} ->
>         (x  : State t) -> .(r  : Reachable x) -> .(v  : Viable (S n) x) ->
>         (gy  : GoodCtrl t x n) ->
>         (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>         PossibleNextState x (ctrl gy) -> Val
> {-
> tsval {t} {n} x r v gy vt (MkSigma x' x'emx') = reward t x y x' `plus` index k vt where
>   y   : Ctrl t x
>   y   = ctrl gy
>   mx' : M (State (S t))
>   mx' = nexts t x y
>   ar' : All Reachable mx'
>   ar' = reachableSpec1 x r y
>   av' : All (Viable n) mx'
>   av' = allViable gy
>   r' : Reachable x'
>   r' = allElemSpec0 x' mx' ar' x'emx'
>   v' : Viable n x'
>   v' = allElemSpec0 x' mx' av' x'emx'
>   rvxs : Vect (cardReachableAndViableState (S t) n) (State (S t))
>   rvxs = map outl (vectReachableAndViableState (S t) n)
>   k    : Fin (cardReachableAndViableState (S t) n)
>   k    = lookup x' rvxs prf' where
>     dRV : (x' : State (S t)) -> Dec (ReachableAndViable n x')
>     dRV = decidableReachableAndViable n
>     prf : Elem x' (vectState (S t))
>     prf = toVectComplete (finiteState (S t)) x'
>     prf' : Elem x' rvxs
>     prf' = filterTagSigmaLemma {P = ReachableAndViable n} dRV x' (vectState (S t)) prf (r',v')
> -}
> tsval {t} {n} x r v gy vt (MkSigma x' x'emx') =
>   let y    : Ctrl t x
>            = ctrl gy in
>   let mx'  : M (State (S t))
>            = nexts t x y in
>   let ar'  : All Reachable mx'
>            = reachableSpec1 x r y in
>   let av'  : All (Viable n) mx'
>            = allViable gy in
>   let r'   : Reachable x'
>            = allElemSpec0 x' mx' ar' x'emx' in
>   let v'   : Viable n x'
>            = allElemSpec0 x' mx' av' x'emx' in
>   let rvxs : Vect (cardReachableAndViableState (S t) n) (State (S t))
>            = map outl (vectReachableAndViableState (S t) n) in
>   let dRV  : ((x' : State (S t)) -> Dec (ReachableAndViable n x'))
>            = decidableReachableAndViable n in
>   let prf  : Elem x' (vectState (S t))
>            = toVectComplete (finiteState (S t)) x' in
>   let prf' : Elem x' rvxs
>            = filterTagSigmaLemma {P = ReachableAndViable n} dRV x' (vectState (S t)) prf (r',v') in
>   let k    : Fin (cardReachableAndViableState (S t) n)
>            = lookup x' rvxs prf' in
>   reward t x y x' `plus` index k vt

Next, we implement a tabulated version of |cval|:

> tcval : {t, n : Nat} ->
>         (x  : State t) -> .(r  : Reachable x) -> .(v  : Viable (S n) x) ->
>         (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>         GoodCtrl t x n -> Val
> {-
> tcval {t} x r v vt gy = meas (fmap (tsval x r v gy vt) (tagElem mx')) where
>   y    : Ctrl t x
>   y    = ctrl gy
>   mx'  :  M (State (S t))
>   mx'  =  nexts t x y
> -}
> tcval {t} x r v vt gy = let y    : Ctrl t x
>                                  = ctrl gy in
>                         let mx'  : M (State (S t))
>                                  = nexts t x y in
>                         meas (fmap (tsval x r v gy vt) (tagElem mx'))

And finally

> tcvalargmax : {t, n : Nat} ->
>               (x  : State t) -> .(r : Reachable x) -> .(v : Viable (S n) x) ->
>               (vt : Vect (cardReachableAndViableState (S t) n) Val) -> GoodCtrl t x n

> toptExt {t} {n} vt = p where
>   p : Policy t (S n)
>   p x r v = tcvalargmax x r v vt

* Tabulated tail-recursive backwards induction

With |toptExt| in place, it is easy to implement a tabulated version of
|trbi|:

> ||| A table of the result of calling |flip val| (roughly) on a policy sequence
> ValueTable : Nat -> Nat -> Type
> ValueTable t n = Vect (cardReachableAndViableState t n) Val

> |||
> PolicySeqAndTab : Nat -> Nat -> Type
> PolicySeqAndTab t n = (PolicySeq t n, ValueTable t n)

> |||
> zeroVec : (n : Nat) -> Vect n Val
> zeroVec Z     = Nil
> zeroVec (S n) = zero :: zeroVec n

> ||| Tabulated tail-recursive backwards induction iteration
> ttrbii : (t : Nat) -> (n : Nat) -> (c : Nat) -> (LTE c n) ->
>          PolicySeq (c + t) (n - c) ->
>          (vt : Vect (cardReachableAndViableState (c + t) (n - c)) Val) ->
>          PolicySeq t n
>
> ttrbii t n  Z     prf ps vt = replace {P = \ z => PolicySeq t z} (minusZeroRight n) ps
>
> {-
> ttrbii t n (S c') prf ps vt = ttrbii t n c' prf' ps' vt'' where
>   bic  : S (n - S c') = n - c'
>   bic  = minusLemma4 prf
>   prf' : LTE c' n
>   prf' = lteLemma1 c' n prf
>   p    : Policy (c' + t) (S (n - S c'))
>   p    = toptExt vt
>   ps'  : PolicySeq (c' + t) (n - c')
>   ps'  = replace {P = \ z => PolicySeq (c' + t) z} bic (p :: ps)
>   vt'  : Vect (cardReachableAndViableState (c' + t) (S (n - S c'))) Val
>   vt'  = toVect vt'f where
>     vt'f : Fin (cardReachableAndViableState (c' + t) (S (n - S c'))) -> Val
>     vt'f k = tcval x r v vt (p x r v) where
>       xrv : Sigma (State (c' + t)) (ReachableAndViable (S (n - S c')))
>       xrv = index k (vectReachableAndViableState (c' + t) (S (n - S c')))
>       x   : State (c' + t)
>       x   = outl xrv
>       r   : Reachable {t' = c' + t} x
>       r   = fst (outr xrv)
>       v   : Viable {t = c' + t} (S (n - S c')) x
>       v   = snd (outr xrv)
>   vt''  : Vect (cardReachableAndViableState (c' + t) (n - c')) Val
>   vt''  = replace {P = \z => Vect (cardReachableAndViableState (c' + t) z) Val} bic vt'
> -}
> ttrbii t n (S c') prf ps vt =
>   let bic  : (S (n - S c') = n - c')
>            = minusLemma4 prf in
>   let prf' : LTE c' n
>            = lteLemma1 c' n prf in
>   let p    : Policy (c' + t) (S (n - S c'))
>            = toptExt vt in
>   let ps'  : PolicySeq (c' + t) (n - c')
>            = replace {P = \ z => PolicySeq (c' + t) z} bic (p :: ps) in
>   let xrv  -- : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Sigma (State (c' + t)) (ReachableAndViable (S (n - S c'))))
>            = \ k => index k (vectReachableAndViableState (c' + t) (S (n - S c'))) in
>   let x    : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> State (c' + t))
>            = \ k => outl (xrv k) in
>   let r    : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Reachable {t' = c' + t} (x k))
>            = \ k => fst (outr (xrv k)) in
>   let v    : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Viable {t = c' + t} (S (n - S c')) (x k))
>            = \ k => snd (outr (xrv k)) in
>   let vt'f : (Fin (cardReachableAndViableState (c' + t) (S (n - S c'))) -> Val)
>            = \ k => tcval (x k) (r k) (v k) vt (p (x k) (r k) (v k)) in
>   let vt'  : Vect (cardReachableAndViableState (c' + t) (S (n - S c'))) Val
>            = toVect vt'f in
>   let vt'' : Vect (cardReachableAndViableState (c' + t) (n - c')) Val
>            = replace {P = \z => Vect (cardReachableAndViableState (c' + t) z) Val} bic vt' in
>   ttrbii t n c' prf' ps' vt''

> ||| Tabulated tail-recursive backwards induction
> tabTailRecursiveBackwardsInduction : (t : Nat) -> (n : Nat) -> PolicySeq t n
> tabTailRecursiveBackwardsInduction t n = ttrbii t n n (reflexiveLTE n) zps (zeroVec _) where
>   zps : PolicySeq (n + t) (n - n)
>   zps = replace {P = \ z => PolicySeq (n + t) z} (minusZeroN n) Nil

> {-

> ---}


--- Day 7: The Treachery of Whales ---

module TheTreacheryOfWhales
import System
import System.File
import Data.List
import Data.List1
import Data.Strings
import Data.Fin
import Util

{--
A giant whale has decided your submarine is its next meal, and it's much faster than you are. There's nowhere to run!

Suddenly, a swarm of crabs (each in its own tiny submarine - it's too deep for them otherwise) zooms in to rescue you! They seem to be preparing to blast a hole in the ocean floor; sensors indicate a massive underground cave system just beyond where they're aiming!

The crab submarines all need to be aligned before they'll have enough power to blast a large enough hole for your submarine to get through. However, it doesn't look like they'll be aligned before the whale catches you! Maybe you can help?

There's one major catch - crab submarines can only move horizontally.

You quickly make a list of the horizontal position of each crab (your puzzle input). Crab submarines have limited fuel, so you need to find a way to make all of their horizontal positions match while requiring them to spend as little fuel as possible.

For example, consider the following horizontal positions:

16,1,2,0,4,2,7,1,2,14
This means there's a crab with horizontal position 16, a crab with horizontal position 1, and so on.

Each change of 1 step in horizontal position of a single crab costs 1 fuel. You could choose any horizontal position to align them all on, but the one that costs the least fuel is horizontal position 2:

Move from 16 to 2: 14 fuel
Move from 1 to 2: 1 fuel +
Move from 2 to 2: 0 fuel +
Move from 0 to 2: 2 fuel
Move from 4 to 2: 2 fuel +
Move from 2 to 2: 0 fuel +
Move from 7 to 2: 5 fuel +
Move from 1 to 2: 1 fuel +
Move from 2 to 2: 0 fuel +
Move from 14 to 2: 12 fuel
This costs a total of 37 fuel. This is the cheapest possible outcome; more expensive outcomes include aligning at position 1 (41 fuel), position 3 (39 fuel), or position 10 (71 fuel).

Determine the horizontal position that the crabs can align to using the least fuel possible. How much fuel must they spend to align to that position?

--- Part Two ---
The crabs don't seem interested in your proposed solution. Perhaps you misunderstand crab engineering?

As it turns out, crab submarine engines don't burn fuel at a constant rate. Instead, each change of 1 step in horizontal position costs 1 more unit of fuel than the last: the first step costs 1, the second step costs 2, the third step costs 3, and so on.

As each crab moves, moving further becomes more expensive. This changes the best horizontal position to align them all on; in the example above, this becomes 5:

Move from 16 to 5: 66 fuel
Move from 1 to 5: 10 fuel
Move from 2 to 5: 6 fuel
Move from 0 to 5: 15 fuel
Move from 4 to 5: 1 fuel
Move from 2 to 5: 6 fuel
Move from 7 to 5: 3 fuel
Move from 1 to 5: 10 fuel
Move from 2 to 5: 6 fuel
Move from 14 to 5: 45 fuel
This costs a total of 168 fuel. This is the new cheapest possible outcome; the old alignment position (2) now costs 206 fuel instead.

Determine the horizontal position that the crabs can align to using the least fuel possible so they can make you an escape route! How much fuel must they spend to align to that position?
--}

abs': Nat -> Nat -> Nat
abs' k j = if k >= j then minus k j else minus j k

median : List Nat -> Maybe Nat
median xs = do
              let int = fromIntegerNat $ div (cast $ length xs) 2
              let (Just idx) = natToFin int $ length xs | Nothing => Nothing
              pure $ index' xs idx

mean: List Nat -> Nat
mean xs = fromIntegerNat $ div (cast $ sum xs) (cast $ length xs)

series: (n: Nat) -> Nat
series n = fromIntegerNat $ div ((cast n) * ((cast n) + 1)) 2

calcFuel: (pos: List Nat) -> Maybe Nat
calcFuel pos = do
                let (Just m) = (median . sort) pos | Nothing => Nothing
                pure $ foldr (plus . abs' m) Z pos

calcFuel2: (pos: List Nat) -> Nat
calcFuel2 pos = min (fuel $ mean pos) (fuel $ S $ mean pos)
                where
                  fuel: (m: Nat) -> Nat
                  fuel m = foldr (plus . series . abs' m) Z pos

main: IO ()
main = do
         args <- getArgs
         let (file :: _) = drop 1 args | [] => putStrLn "No file provided!"
         (Right symbols) <- readFile file | (Left error) => putStrLn $ show error
         let (Just pos) = consolidate $ map parsePositive $ forget $ split ( == ',') symbols | Nothing => putStrLn "Parsing error!"
         let (Just fuel) = calcFuel pos | Nothing => pure ()
         putStrLn . show $ fuel
         putStrLn . show $ calcFuel2 pos


totalLen : List String -> Nat
totalLen [] = 0
totalLen xs = foldr (\str, len => length str + len) 0 xs


module ShapeExercises

import Shape

area : Shape -> Double
area s with (shapeView s)
  area (triangle x y) | STriangle   = 0.5 * x * y
  area (rectangle x y) | SRectangle = x * y
  area (circle x) | SCircle         = pi * x * x


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

> %name Vect xs, ys, zs

> my_cong : forall f . (x : a) -> (y : a) -> x = y -> f x = f y

> my_curry : ((a, b) -> c) -> a -> b -> c

> my_uncurry : (a -> b -> c) -> (a, b) -> c

> append : Vect n a -> Vect m a -> Vect (n + m) a

> lappend : (1 xs : List a) -> (1 ys : List a) -> List a

> zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

> data Env : Vect n Type -> Type where
>      ENil : Env []
>      ECons : a -> Env xs -> Env (a :: xs)

> %name Env es

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

> lookup : Elem ty vs -> Env vs -> ty


module Test.Int64

import Data.Prim.Int64
import Data.SOP
import Hedgehog
import Test.RingLaws

allInt64 : Gen Int64
allInt64 = int64 (linear (-0x8000000000000000) 0xffffffffffffffff)

prop_ltMax : Property
prop_ltMax = property $ do
  b8 <- forAll allInt64
  (b8 <= MaxInt64) === True

prop_ltMin : Property
prop_ltMin = property $ do
  b8 <- forAll allInt64
  (b8 >= MinInt64) === True

prop_comp : Property
prop_comp = property $ do
  [m,n] <- forAll $ np [allInt64, allInt64]
  toOrdering (comp m n) === compare m n

export
props : Group
props = MkGroup "Int64" $
  [ ("prop_ltMax",  prop_ltMax)
  , ("prop_ltMin",  prop_ltMin)
  , ("prop_comp",   prop_comp)
  ] ++ ringProps allInt64


module Verified.Algebra.Nat

import Classes.Verified

%default total

fromAdditive : Additive -> Nat
fromAdditive (getAdditive n) = n

natAndAdditive1 : fromAdditive (getAdditive n) = n
natAndAdditive1 = Refl

natAndAdditive2 : getAdditive (fromAdditive n) = n
natAndAdditive2 {n=getAdditive n'}= Refl

natAndAdditiveOp1 : fromAdditive (getAdditive n <+> getAdditive m) = n + m
natAndAdditiveOp1 = Refl

natAndAdditiveOp2 : getAdditive (fromAdditive n + fromAdditive m) = n <+> m
natAndAdditiveOp2 {n=getAdditive n'} {m=getAdditive m'} = Refl

fromMultiplicative : Multiplicative -> Nat
fromMultiplicative (getMultiplicative n) = n

natAndMultiplicative1 : fromMultiplicative (getMultiplicative n) = n
natAndMultiplicative1 = Refl

natAndMultiplicative2 : getMultiplicative (fromMultiplicative n) = n
natAndMultiplicative2 {n=getMultiplicative n'} = Refl

natAndMultiplicativeOp1 : fromMultiplicative (getMultiplicative n <+> getMultiplicative m) = n * m
natAndMultiplicativeOp1 = Refl

natAndMultiplicativeOp2 : getMultiplicative (fromMultiplicative n * fromMultiplicative m) = n <+> m
natAndMultiplicativeOp2 {n=getMultiplicative n'} {m=getMultiplicative m'} = Refl

instance VerifiedSemigroup Additive where
  semigroupOpIsAssociative (getAdditive l) (getAdditive c) (getAdditive r) =
    ?lemmaAdditiveAssoc

instance VerifiedMonoid Additive where
  monoidNeutralIsNeutralL (getAdditive l) = ?lemmaAdditiveNeutralL
  monoidNeutralIsNeutralR (getAdditive r) = ?lemmaAdditiveNeutralR

instance VerifiedSemigroup Multiplicative where
  semigroupOpIsAssociative (getMultiplicative l) (getMultiplicative c) (getMultiplicative r) =
    ?lemmaMultiplicativeAssoc

instance VerifiedMonoid Multiplicative where
  monoidNeutralIsNeutralL (getMultiplicative l) = ?lemmaMultiplicativeNeutralL
  monoidNeutralIsNeutralR (getMultiplicative r) = ?lemmaMultiplicativeNeutralR

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

Verified.Algebra.Nat.lemmaMultiplicativeNeutralL = proof
  intros
  rewrite multOneRightNeutral l
  exact Refl

Verified.Algebra.Nat.lemmaMultiplicativeNeutralR = proof
  intros
  rewrite multOneLeftNeutral r
  exact Refl

Verified.Algebra.Nat.lemmaMultiplicativeAssoc = proof
  intros
  rewrite multAssociative l c r
  exact Refl

Verified.Algebra.Nat.lemmaAdditiveNeutralL = proof
  intros
  rewrite (plusZeroRightNeutral l)
  exact Refl

Verified.Algebra.Nat.lemmaAdditiveNeutralR = proof
  intros
  exact Refl

Verified.Algebra.Nat.lemmaAdditiveAssoc = proof
  intros
  rewrite (plusAssociative l c r)
  exact Refl


module Demo

import Data.Vect

-- %default total

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

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

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

take' : (n : Nat) -> Vect (n + m) a -> Vect n a
take' = ?rhs

total
head' : Vect (S n) a -> a
head' (x :: xs) = x


import System
import Fuel
import Arith

import Command

data Input = Answer Int
           | QuitCmd

data Score = MkScore Nat Nat

Show Score where
  show (MkScore y n) = (show y ++ " / " ++ show (y + n))

addCorrect : Score -> Score
addCorrect (MkScore k j) = MkScore (k + 1) j

addWrong : Score -> Score
addWrong (MkScore k j) = MkScore k (j + 1)

readInput : (prompt : String) -> Command Input
readInput prompt = do
  PutStr prompt
  answer <- GetLine
  if toLower answer == "quit"
    then Pure QuitCmd
    else Pure (Answer (cast answer))

mutual
  correct : Stream Int -> (score : Score) -> ConsoleIO Score
  correct nums score
    = do PutStr "Correct!\n"
         quiz nums (addCorrect score)

  wrong : Stream Int -> Int -> (score : Score) -> ConsoleIO Score
  wrong nums answer score
    = do PutStr ("Wrong, the answer is " ++ show answer ++ "\n")
         quiz nums (addWrong score)

  quiz : Stream Int -> (score : Score) -> ConsoleIO Score
  quiz (num1 :: num2 :: nums) score
    = do PutStr ("Score: " ++ show score ++ "\n")
         input <- readInput (show num1 ++ " * " ++ show num2 ++ " ")
         case input of
           Answer answer => if (answer == num1 * num2)
                             then correct nums score
                             else wrong nums (num1 * num2) score
           QuitCmd => Quit score

partial
main : IO ()
main = do
  seed <- time
  Just score <- run forever (quiz (arithInputs (fromInteger seed)) (MkScore 0 0))
       | Nothing => putStrLn "Out Of Fuel"

  putStrLn ("Final Score: " ++ show score)


import data.Vect

||| Vect of numbers from a to (b - 1)
total range2 : (start: Nat) -> (end: Nat) -> Vect (end `minus` start) Nat
range2 start end = range' (end `minus` start)
where total range' : (a: Nat) -> Vect a Nat
      range' Z     = []
      range' (S k) = (end `minus` (S k)) :: (range' k)


module xquant.Spinor.BKS

import Data.Vect
import xquant.Spinor.Sigmas
import xquant.Spinor.SigKets

%default total

-----------------------------------------------------------------------
--                           Commutation
-----------------------------------------------------------------------

||| Individual Pauli operators commute iff they are identical up to a phase,
||| or if one of them is the identity
data PauliComm : Pauli -> Pauli -> Type where
  PSame    : (p : Pauli) -> PauliComm p  p
  PIdRight : (p : Pauli) -> PauliComm p  SI
  PIdLeft  : (p : Pauli) -> PauliComm SI p

||| Pauli operators do not commute iff they are not identical up to a phase,
||| and one of them isn't the identity
data PauliNonComm : Pauli -> Pauli -> Type where
  NonCommXY : PauliNonComm SX SY
  NonCommYZ : PauliNonComm SY SZ
  NonCommZX : PauliNonComm SZ SX
  NonCommSwap : PauliNonComm q w -> PauliNonComm w q

||| Decide whether two Pauli operators commute or not
decCommPauli : (x : Pauli) -> (y : Pauli) -> Either (PauliComm x y) (PauliNonComm x y)
decCommPauli SI p  = Left $ PIdLeft p
decCommPauli p  SI = Left $ PIdRight p
decCommPauli SX SX = Left $ PSame SX
decCommPauli SY SY = Left $ PSame SY
decCommPauli SZ SZ = Left $ PSame SZ
decCommPauli SX SY = Right $ NonCommXY
decCommPauli SY SX = Right $ NonCommSwap NonCommXY
decCommPauli SY SZ = Right $ NonCommYZ
decCommPauli SZ SY = Right $ NonCommSwap NonCommYZ
decCommPauli SZ SX = Right $ NonCommZX
decCommPauli SX SZ = Right $ NonCommSwap NonCommZX

mutual
  ||| A pair of commuting Sigma operators is formed by prepending a pair of commuting Paulis
  ||| onto a pair of commuting Sigmas, or by prepending a pair of non-commuting Paulis onto
  ||| a pair of non-commuting Sigmas. Sigmas of level zero (pure numbers) trivially commute.
  data Commuting : Sigma n -> Sigma n -> Type where
    CommPhase : {s1,s2 : Sigma Z} -> Commuting s1 s2
    CommSame  : PauliComm    j k -> Commuting    g h -> Commuting (Sig j g) (Sig k h)
    CommDiff  : PauliNonComm j k -> NonCommuting g h -> Commuting (Sig j g) (Sig k h)

  ||| A pair of non-commuting Sigma operators is formed by prepending a pair of commuting Paulis
  ||| onto a pair of non-commuting Sigmas, or by prepending a pair of non-commuting Paulis onto
  ||| a pair of commuting Sigmas.
  data NonCommuting : Sigma n -> Sigma n -> Type where
    NoCommSame : PauliNonComm j k -> Commuting    g h -> NonCommuting (Sig j g) (Sig k h)
    NoCommDiff : PauliComm    j k -> NonCommuting g h -> NonCommuting (Sig j g) (Sig k h)

||| Decide whether two Sigma operators commute or not
decComm : (x : Sigma n) -> (y : Sigma n) -> Either (Commuting x y) (NonCommuting x y)
decComm (sPhase p1) (sPhase p2) = Left CommPhase
decComm (Sig p1 s1) (Sig p2 s2) with (decComm s1 s2)
  decComm (Sig p1 s1) (Sig p2 s2) | commPrf with (decCommPauli p1 p2)
    decComm (Sig p1 s1) (Sig p2 s2) | Left cm  | Left  cmp = Left  $ CommSame cmp cm
    decComm (Sig p1 s1) (Sig p2 s2) | Left cm  | Right ncp = Right $ NoCommSame ncp cm
    decComm (Sig p1 s1) (Sig p2 s2) | Right nc | Left  cmp = Right $ NoCommDiff cmp nc
    decComm (Sig p1 s1) (Sig p2 s2) | Right nc | Right ncp = Left  $ CommDiff ncp nc

commTest : Vect n (Sigma m) -> Bool
commTest []        = True
commTest (x :: xs) = all (commute x) xs && (commTest xs)

data MutuallyCommuting : Vect n (Sigma m) -> Type where
  IsMutuallyCommuting : (v : Vect n $ Sigma m) ->
                        commTest v = True ->
                        MutuallyCommuting v

data CommStatus : (x : Sigma n) -> (y : Sigma n) -> Type where
  Status_Comm   : Commuting    x y -> CommStatus x y
  Status_NoComm : NonCommuting x y -> CommStatus x y

-----------------------------------------------------------------------
--        Even Parity (for each subspace & generator) datatype
-----------------------------------------------------------------------

data Parity = Even | Odd

data PauliParity = PParity Parity Parity Parity

swap : Parity -> Parity
swap Even = Odd
swap Odd  = Even

updateP : Pauli -> PauliParity -> PauliParity
updateP SX (PParity x y z) = PParity (swap x) y z
updateP SY (PParity x y z) = PParity x (swap y) z
updateP SZ (PParity x y z) = PParity x y (swap z)
updateP SI p               = p

updateParity : Sigma n -> Vect n PauliParity -> Vect n PauliParity
updateParity (sPhase ph) []      = []
updateParity (Sig pl s)  (p::ps) = (updateP pl p) :: (updateParity s ps)

||| Sets of Sigma n operators can be classified by whether each Sigma occurs
||| an even or odd number of times in each single-qubit Hilbert Space
data SigmaParity : Vect n (Sigma m) -> Vect m PauliParity -> Type where
  ParityZero : {m : Nat} -> SigmaParity [] (replicate m $ PParity Even Even Even)
  ParityNext : {v : Vect n (Sigma m)} ->
               (s : Sigma m) ->
               SigmaParity v p ->
               SigmaParity (s::v) (updateParity s p)

data EvenParity : Vect n (Sigma m) -> Type where
  IsEven : {v : Vect n (Sigma m)} ->
           SigmaParity v (replicate m $ PParity Even Even Even) ->
           EvenParity v

evenParity : (n : Nat) -> Vect n PauliParity
evenParity n = replicate n $ PParity Even Even Even

-----------------------------------------------------------------------
--               Multiply-to-Negative-Identity datatype
-----------------------------------------------------------------------

data NegId : Vect n (Sigma m) -> Type where
  IsNegId : (v : Vect (S n) (Sigma m)) ->
            foldr1 (<>) v = negId m ->
            NegId v

-----------------------------------------------------------------------
--                      BKS Theorem datatype
-----------------------------------------------------------------------

data BKS : Vect n (Sigma m) -> Type where
  MkBKS : MutuallyCommuting v ->
          NegId v ->
          EvenParity v ->
          BKS v

-----------------------------------------------------------------------
--      5-qubit BKS proof of David DiVincenzo & Asher Peres
-----------------------------------------------------------------------

zzzzz : Sigma 5
zzzzz = sZ <&> sZ <&> sZ <&> sZ <&> sZ

zxIIx : Sigma 5
zxIIx = sZ <&> sX <&> sI <&> sI <&> sX

xzxII : Sigma 5
xzxII = sX <&> sZ <&> sX <&> sI <&> sI

IxzxI : Sigma 5
IxzxI = sI <&> sX <&> sZ <&> sX <&> sI

IIxzx : Sigma 5
IIxzx = sI <&> sI <&> sX <&> sZ <&> sX

xIIxz : Sigma 5
xIIxz = sX <&> sI <&> sI <&> sX <&> sZ

Asher_David : Vect 6 (Sigma 5)
Asher_David = [zzzzz,
               zxIIx,
               xzxII,
               IxzxI,
               IIxzx,
               xIIxz]

Asher_David_Commuting : MutuallyCommuting Asher_David
Asher_David_Commuting = IsMutuallyCommuting Asher_David Refl

Asher_David_NegId : NegId Asher_David
Asher_David_NegId = IsNegId Asher_David Refl

Asher_David_Parity : SigmaParity Asher_David $ evenParity 5
Asher_David_Parity = ParityNext zzzzz $
                     ParityNext zxIIx $
                     ParityNext xzxII $
                     ParityNext IxzxI $
                     ParityNext IIxzx $
                     ParityNext xIIxz ParityZero

Asher_David_EvenParity : EvenParity Asher_David
Asher_David_EvenParity = IsEven Asher_David_Parity

Asher_David_BKS : BKS Asher_David
Asher_David_BKS = MkBKS Asher_David_Commuting Asher_David_NegId Asher_David_EvenParity

-----------------------------------------------------------------------
--       4-qubit BKS proof of Aravind-Chryssanthacopoulos-Harvey
-----------------------------------------------------------------------

xxxx : Sigma 4
xxxx = sX <&> sX <&> sX <&> sX

xxzz : Sigma 4
xxzz = sX <&> sX <&> sZ <&> sZ

zxxz : Sigma 4
zxxz = sZ <&> sX <&> sX <&> sZ

zxzx : Sigma 4
zxzx = sZ <&> sX <&> sZ <&> sX

Aravind : Vect 4 (Sigma 4)
Aravind = [xxxx,
           xxzz,
           zxxz,
           zxzx]

Aravind_Commuting : MutuallyCommuting Aravind
Aravind_Commuting = IsMutuallyCommuting Aravind Refl

Aravind_NegId : NegId Aravind
Aravind_NegId = IsNegId Aravind Refl

Aravind_Parity : SigmaParity Aravind $ evenParity 4
Aravind_Parity = ParityNext xxxx $
                 ParityNext xxzz $
                 ParityNext zxxz $
                 ParityNext zxzx ParityZero

Aravind_Even_Parity : EvenParity Aravind
Aravind_Even_Parity = IsEven Aravind_Parity

Aravind_BKS : BKS Aravind
Aravind_BKS = MkBKS Aravind_Commuting Aravind_NegId Aravind_Even_Parity


> %default total
> %auto_implicits off

> X : Type
> H : Type
> fulfils : X -> H -> Bool

> LTE : H -> H -> Type
> LTE h1 h2 = (x : X) -> fulfils x h1 = True -> fulfils x h2 = True

> antisymmetricLTE : (h1 : H) -> (h2 : H) -> h1 `LTE` h2 -> h2 `LTE` h1 ->
>                    (x : X) -> fulfils x h1 = fulfils x h2
> antisymmetricLTE h1 h2 p q y with (fulfils y h1)
>   | True  = ?kika
>   | False = ?kiko


module Shenanigans

double : Num a => a -> a
double x = x + x

add : Num a => a -> a -> a
add x y = ?todo

id : a -> a
id x = x

||| Apply a function two times
||| @f The function to apply
||| @x The argument to supply
twice : (f : a -> a) -> (x : a) -> a
twice f x = f (f x)

Shape : Type
-- this function has a hole! (no definition)
rotate : Shape -> Shape

turn_around : Shape -> Shape
turn_around = twice rotate

pythagoras : Double -> Double -> Double
pythagoras x y = sqrt (square x + square y)
  where
    square : Double -> Double
    square x = x*x


module Corecords

-- Standard Streams

corecord Stream' : Type -> Type where
  hd : Stream' a -> a
  tl : Stream' a -> Stream' a
  constructor MkStream' (hd tl)

record Foo : Type -> Type where
  MkFoo : (bar : a) -> (baz : Foo a) -> Foo a

-- Bisimilarity for streams
-- Thanks to asal@itu.dk
-- Ahmad Salim Al-Sibahi

{-
Does not work.

corecord BisimStream' : Stream' a -> Stream' a -> Type where
  phd : BisimStream' s s' -> (hd s) = (hd s')
  ptl : BisimStream' s s' -> BisimStream' (tl s) (tl s')
-}

corecord BisimStream' : (a : Type) -> Stream' a -> Stream' a -> Type where
  phd : BisimStream' a s s' -> (hd s) = (hd s')
  ptl : BisimStream' a s s' -> BisimStream' a (tl s) (tl s')

-- CoTree

corecord CoTree : Type -> Type where
  value : CoTree a -> a
  left  : CoTree a -> CoTree a
  right : CoTree a -> CoTree a

-- Globular types
-- https://code.google.com/p/agda/issues/detail?id=906

corecord Glob : Type where
  Ob : Glob -> Type
  Hom : Glob -> Glob -> Glob -> Glob

Unit_glob : Glob
Unit_glob = MkGlob Unit (\_, _ => Unit_glob)

Id_glob : Type -> Glob
Id_glob a = MkGlob a (\a, b => Id_glob (a = b))

-- Dependent Projections
{-
corecord Foo : Type where
  bar : Foo -> Bool
  baz : (f : Foo) -> if bar f then Nat else Bool -> Foo
  constructor MkFoo (bar baz)-}


Symmetric : {c : Type} -> (c -> c -> Type) -> Type
Symmetric {c} rel = {a : c} -> {b : c} -> rel a b -> rel b a

record Symmetry (t : Type) (rel : t -> t -> Type) where
  constructor MkSymmetry
  is_symmetric : Symmetric {c=t} rel

symmetry : {ty : Type} -> Symmetry ty (=)
symmetry = MkSymmetry sym


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

%name InfList xs, ys, zs

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

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

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


module Dudo

import Data.Vect
import SillyTypes

data Die : NumDieSides -> Type where
  MkDie :
    {dieNumSides : NumDieSides} ->
    (dieConfiguration : PeanoFin dieNumSides) ->
    Die numSides

data Player : NumDice -> NumDieSides -> Type where
  MkPlayer :
    (name : NonEmptyString) ->
    {numDice : NumDice} ->
    (numDiceInPlay : Nat) ->
    (numDiceNotInPlay : Nat) ->
    {dice_consistent : (natRep numDice) = (numDiceInPlay + numDiceNotInPlay)} ->
    {dieSides : NumDieSides} ->
    (diceInPlay : Vect numDiceInPlay (Die dieSides)) ->
    (diceNotInPlay : Vect numDiceNotInPlay (Die dieSides)) ->
    Player numDice dieSides

data Table : NumPlayers -> NumDice -> NumDieSides -> Type where
  MkTable :
    {tableNumPlayers : NumPlayers} ->
    {tableNumDicePerPlayer : NumDice} ->
    {tableNumDieSides : NumDieSides} ->
    (tablePlayers : Vect (natRep tableNumPlayers)
                         (Player tableNumDicePerPlayer tableNumDieSides)) ->
    Table numPlayers numDice numDieSides


module Equis.Solver

import Matrix.Numeric
import Data.Matrix.Numeric

%access private

||| Solves a system of linear equations.
|||
||| @coeff the matrix of coefficients
||| @sols the solutions
export
solve : Neg a => Fractional a => (coeff : Matrix (S n) (S n) a) -> (sols : Vect (S n) a) -> Vect (S n) a
solve coeff sols = (inverse coeff) </> sols


-- -------------------------------------------------------------- [ Lens.idr ]
-- Description : Idris port of Control.Lens
-- Copyright   : (c) Huw Campbell
-- --------------------------------------------------------------------- [ EOH ]
module Control.Lens.Examples
import Control.Lens

--
-- Examples of interactions available with these Lenses
--

Ex1 : Maybe Int
Ex1 = over mapped (+1) (Just 2)

Ex1Proof : Ex1 = Just 3
Ex1Proof = Refl

Ex2 : (Int, Int)
Ex2 = (2,3) & over both (+1)

Ex2Proof : Ex2 = (3, 4)
Ex2Proof = Refl

Ex3 : (String, String)
Ex3 = ("Hello",2) & _2 .~ "World!"

Ex3Proof : Ex3 = ("Hello","World!")
Ex3Proof = Refl

Ex4 : Either String Int
Ex4 = f (Left "hi")
  where f : Either String Int -> Either String Int
        f = over _Right (+1)

Ex4Proof : Ex4 = (Left "hi")
Ex4Proof = Refl

Ex5 : Either String Int
Ex5 = f (Right 4)
  where f : Either String Int -> Either String Int
        f = over _Right (+1)

Ex5Proof : Ex5 = (Right 5)
Ex5Proof = Refl

Ex6 : Either (String, Int) Int
Ex6 = f (Left ("hi", 2))
  where f : Either (String,Int) Int -> Either (String,Int) Int
        f = over (_Left . _2) (+1)

Ex6Proof : Ex6 = Left ("hi", 3)
Ex6Proof = Refl

Ex7 : Additive
Ex7 = f (Left ("hi", GetAdditive 2)) where
  f : Either (String, Additive) Int -> Additive
  f = view (_Left . _2)

Ex7Proof : Ex7 = (GetAdditive 2)
Ex7Proof = Refl

Ex8 : Additive
Ex8 = f (Right 2) where
  f : Either (String, Additive) Int -> Additive
  f = view (_Left . _2)

Ex8Proof : Ex8 = (GetAdditive 0)
Ex8Proof = Refl

Ex9 : Maybe String
Ex9 = g ^? _Right . _1 where
 g : Either String (String, Int)
 g = Right ("x",2)

Ex9Proof : Ex9 = Just "x"
Ex9Proof = Refl

Ex10 : Maybe ()
Ex10 = Just "x" ^? _Nothing

Ex10Proof : Ex10 = Nothing
Ex10Proof = Refl

Ex11 : Maybe ()
Ex11 = n ^? _Nothing where
  n : Maybe String
  n = Nothing

Ex11Proof : Ex11 = Just ()
Ex11Proof = Refl

Ex12 : Int
Ex12 = view (to fst) (1,2)

Ex12Proof : Ex12 = 1
Ex12Proof = Refl

Ex13 : Either Int String
Ex13 = the (Either Int String) $ _Left # 4

Ex13Proof : Ex13 = Left 4
Ex13Proof = Refl

Ex14 : Either Int String
Ex14 = the (Either Int String) $ 5 ^.re _Left

Ex14Proof : Ex14 = Left 5
Ex14Proof = Refl

sansExample : Maybe Int
sansExample = sans () (Just 4)

fusingExample : Maybe (Int, Int)
fusingExample = Just (2,3) & over ( fusing (_Just . both)) (+1)

confusingExample : Maybe (Int, Int)
confusingExample = Just (2,3) & over ( confusing (_Just . both)) (+1)

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


import Data.List.Views

total
equalSuffix : Eq a => List a -> List a -> List a
equalSuffix xs ys with (snocList xs)
  equalSuffix [] ys | Empty = []
  equalSuffix (zs ++ [x]) ys | (Snoc rec) with (snocList ys)
    equalSuffix (xs' ++ [x]) [] | (Snoc rec) | Empty = []
    equalSuffix (xs' ++ [x]) (ys' ++ [y]) | (Snoc rec_xs) | (Snoc rec_ys)
      = if x == y
        then (equalSuffix xs' ys' | rec_xs | rec_ys) ++ [x]
        else []


module Transversals

import Group
import GroupCosets
import GroupCosetRep
%access public export

--Proof that the definitional equality for Transversal multiplication holds
MulTransDefPf: (h: Type) -> ((+) : h -> h -> h) -> (pf1: IsGroup h (+)) ->
                (g: Type) -> ((*) : g -> g -> g) -> (pf2: IsGroup g (*)) ->
                (sbgrp: Subgroup h (MkGroup h (+) pf1) g (MkGroup g (*) pf2)) -> (trav: Type) ->
                (pftrav: IsTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav) -> (y: trav) -> (z: trav) ->
                (MulTrans trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) y z) =
                  ((DPair.fst (DPair.snd ((Basics.snd (DPair.snd pftrav)) (((DPair.fst pftrav) y)*((DPair.fst pftrav) z))) )))
MulTransDefPf 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
MulTransHomPf: (h: Type) -> ((+) : h -> h -> h) -> (pf1: IsGroup h (+)) ->
                (g: Type) -> ((*) : g -> g -> g) -> (pf2: IsGroup g (*)) ->
                (sbgrp: Subgroup h (MkGroup h (+) pf1) g (MkGroup g (*) pf2)) -> (trav: Type) ->
                (pftrav: IsTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav) -> (y: trav) -> (z: trav) ->
                ((DPair.fst (DPair.snd ((Basics.snd (DPair.snd pftrav)) (((DPair.fst pftrav) y)*((DPair.fst pftrav) z))) ))) = (MulTrans trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) ((DPair.fst (DPair.snd ((Basics.snd (DPair.snd pftrav)) (((DPair.fst pftrav) y))) ))) ((DPair.fst (DPair.snd ((Basics.snd (DPair.snd pftrav)) (((DPair.fst pftrav) z))) ))))
MulTransHomPf 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: (MulTrans trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) y z) = ((fst (snd ((snd (snd pftrav)) (((fst pftrav) y)*((fst pftrav) z))) )))
  MulTravDefProof = (MulTransDefPf h (+) pf1 g (*) pf2 sbgrp trav pftrav y z )

  f1: trav -> trav
  f1 x = MulTrans trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) x z

  f2: trav -> trav
  f2 x = MulTrans trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) ((DPair.fst (DPair.snd ((Basics.snd (DPair.snd pftrav)) (((DPair.fst pftrav) y) ) )) )) x

  CorepFInverseY: (((fst (snd ((snd (snd pftrav)) ((fst pftrav) y) ) )) ) = y)
  CorepFInverseY = CorepFinv trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) y

  CorepFInverseZ: (((fst (snd ((snd (snd pftrav)) ((fst pftrav) z) ) )) ) = z)
  CorepFInverseZ = CorepFinv trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) z


> module Finite.Properties

> import Data.Fin
> import Data.Vect
> import Data.Vect.Quantifiers
> import Control.Isomorphism

> import Finite.Predicates
> import Finite.Operations
> import Decidable.Predicates
> import Fin.Operations
> import Fin.Properties
> import Vect.Properties
> -- import Isomorphism.Operations
> import Isomorphism.Properties
> import Nat.LTProperties
> import Basic.Operations
> import Fun.Properties
> import Sigma.Sigma
> import Pairs.Operations
> import Tuple.Properties

> %default total

> %access public export

* |Fin n| is finite

> finiteFin : {n : Nat} -> Finite (Fin n)
> finiteFin {n} = MkSigma n isoRefl

* Representations of finite types

> -- toVectComplete : {A : Type} -> (f : Fin n -> A) -> (k : Fin n) -> Elem (f k) (toVect f)

> ||| |toVect| representations of finite types are complete
> toVectComplete : {A : Type} -> (fA : Finite A) -> (a : A) -> Elem a (toVect fA)
> toVectComplete (MkSigma _ iso) a = s3 where
>   s1  :  Elem (from iso (to iso a)) (toVect (from iso))
>   s1  =  toVectComplete (from iso) (to iso a)
>   s2  :  from iso (to iso a) = a
>   s2  =  fromTo iso a
>   s3  :  Elem a (toVect (from iso))
>   s3  =  replace {P = \ z => Elem z (toVect (from iso))} s2 s1
> {-
> toVectComplete fA a = s3 where
>   s1  :  Elem (fromFin fA (toFin fA a)) (toVect fA)
>   s1  =  FinProperties.toVectComplete (fromFin fA) (toFin fA a)
>   s2  :  fromFin fA (toFin fA a) = a
>   s2  =  FromFinToFin fA a
>   s3  :  Elem a (toVect fA)
>   s3  =  replace {P = \ z => Elem z (toVect fA)} s2 s1
> -}
> %freeze toVectComplete -- frozen

> ||| |toVect| representations of finite types are injective
> toVectInjective1 : {A : Type} -> (fA : Finite A) -> Injective1 (toVect fA)
> toVectInjective1 {A} (MkSigma _ iso) i j p = s3 where
>   s1 : index i (toVect (from iso)) = index j (toVect (from iso))
>   s1 = p
>   s2 : (from iso) i = (from iso) j
>   s2 = replace2 {a = A} {a1 = index i (toVect (from iso))} {a2 = (from iso) i}
>                 {b = A} {b1 = index j (toVect (from iso))} {b2 = (from iso) j}
>                 {P = \ a => \b => a = b}
>                 (toVectRepr (from iso) i) (toVectRepr (from iso) j) s1
>   s3 : i = j
>   s3 = injectiveFrom iso i j s2
> %freeze toVectInjective1 -- frozen

* Non empty finite types

> |||
> cardNotZLemma : {A : Type} -> (fA : Finite A) -> A -> CardNotZ fA
> cardNotZLemma fA a = gtZisnotZ (elemLemma {n = card fA} a (toVect fA) (toVectComplete fA a))
> %freeze cardNotZLemma -- frozen

We want to show that, for a finite type |A| and a decidable predicate |P
: A -> Type|, |Exists P| is decidable

< finiteDecLemma : {A : Type} -> {P : A -> Type} -> Finite A -> Dec1 P -> Dec (Exists P)

(See also |finiteDecLemma2| which is a proof without using vectors.)

It is useful to recall (see "VectProperties.lidr") that

< decAny         : {A : Type} -> {P : A -> Type} -> Dec1 P -> Dec1 (Any P)
< AnyExistsLemma : {A : Type} -> {P : A -> Type} -> Any P as -> Exists P
< ElemAnyLemma   : {A : Type} -> {P : A -> Type} -> P a -> Elem a as -> Any P as

With these premises, proving |finiteDecLemma| is almost straightforward:

> finiteDecLemma : {A : Type} -> {P : A -> Type} -> Finite A -> Dec1 P -> Dec (Exists P)
> finiteDecLemma fA dP with (decAny dP (toVect fA))
>   | (Yes prf)   = Yes (AnyExistsLemma prf)
>   | (No contra) = No (\ e => contra (ElemAnyLemma (getProof e) (toVectComplete fA (getWitness e))))
> %freeze finiteDecLemma -- frozen

We pattern match on |decAny dP (toVect fA)|: the result is either a |prf
: Any P (toVect fA)| or a function |contra : Any P (toVect fA) ->
Void|. In the first case we just apply |AnyExistsLemma| to |prf|. This
gives us a value of type |Exists P| which is what we need. In the second
case we have to implement a function of type |Exists P -> Void|. We do
this by applying |contra|. To this end, we need a value of type |Any P
(toVect fA)|. We compute a value of type |Any P (toVect fA)| by applying
|ElemAnyLemma|.

> finiteDecSigmaLemma : {A : Type} -> {P : A -> Type} -> Finite A -> ((a : A) -> Dec (P a)) -> Dec (Sigma A P)
> finiteDecSigmaLemma fA dP with (decAny dP (toVect fA))
>   | (Yes prf)   = Yes (AnySigmaLemma prf)
>   | (No contra) = No (\ e => contra (ElemAnyLemma (getProof e) (toVectComplete fA (getWitness e))))

* Finiteness of products

> ||| If |P| and |Q| are finite, |(P , Q)| is finite
> finiteProduct : {A, B : Type} -> Finite A -> Finite B -> Finite (A, B)
> -- finiteProduct {A} {B} (Evidence m isoA) (Evidence n isoB) =
> --   Evidence (m * n) (isoTrans (pairCong isoA isoB) finPairTimes)
> finiteProduct {A} {B} (MkSigma _ isoA) (MkSigma _ isoB) =
>   MkSigma _ (isoTrans (pairCong isoA isoB) finPairTimes)
> %freeze finiteProduct -- frozen

> finitePair : {A, B : Type} -> Finite A -> Finite B -> Finite (A, B)
> finitePair = finiteProduct
> %freeze finitePair -- frozen

> ||| Tuples of 3 finite types are finite
> finiteTuple3 : {A, B, C : Type} ->
>                Finite A -> Finite B -> Finite C ->
>                Finite (A, B, C)
> finiteTuple3 {A} {B} {C} fA fB fC =
>   MkSigma _ (isoTrans (tuplePairIso3 {A} {B} {C}) (getProof fABC)) where
>     fAB  : Finite (A, B)
>     fAB  = finiteProduct fA fB
>     fABC : Finite ((A, B), C)
>     fABC = finiteProduct fAB fC

> ||| ||| Tuples of 4 finite types are finite
> finiteTuple4 : {A, B, C, D : Type} ->
>                Finite A -> Finite B -> Finite C ->  Finite D ->
>                Finite (A, B, C, D)
> finiteTuple4 {A} {B} {C} {D} fA fB fC fD =
>   MkSigma _ (isoTrans (tuplePairIso4 {A} {B} {C} {D}) (getProof fABCD)) where
>     fABC  : Finite (A, B, C)
>     fABC  = finiteTuple3 fA fB fC
>     fABCD : Finite ((A, B, C), D)
>     fABCD = finiteProduct fABC fD

> {- we have to comply with the new |record| syntax for this to type check

----

Porting the proof from the Vect world to the Finite world.

Pseudo-code: case on the size |n| of the finite set
0: empty set => No
(n+1): case P (A 0) of
         Yes -> Yes
         No  -> recursive call with slightly smaller Finite

Some helpers needed to map between Dec's etc.
In fact, Iso is not needed - we can map already with just any pair of functions:

> decIso' : {X : Type} -> {Y : Type} -> (to : X -> Y) -> (from : Y -> X) -> Dec X -> Dec Y
> decIso' to from (Yes x) = Yes (to x)
> decIso' to from (No nx) = No (nx . from)

> decIso : {X : Type} -> {Y : Type} -> Iso X Y -> Dec X -> Dec Y
> decIso (MkIso to from _ _) = decIso' to from

This |lemma| is roughly where we want to end up:

< lemma : (n : Nat) -> {A : Type} -> FiniteN n A -> {P : A -> Type} -> Dec1 P -> Dec (Exists P)

But let's start with a simpler version, ignoring A for now:

< decExistsFin : (n : Nat) -> (P : Fin n -> Type) -> (dP : Dec1 P) -> Dec (Exists P)

Dec (Exists P) is either Yes (an index (i : Fin n) and a proof (p : P
i)) or No (a function showing that any such "index+proof-pair" is
absurd). To show that, we compute the lowest index for which we get a
Yes, or No if no such index exists.

A predicate over |Fin n| can be seen as a vector, so we use the
helper function |tail| from FinOperations.lidr:

< tail : {A : Type} -> (Fin (S n) -> A) -> (Fin n -> A)
< tail P = P . FS

Similarly |Dec1| over |Fin n| can be seen as a vector of decidability
tests. Thus we also need a |Dec1|-version of tail:

> tailDec1 : {n : Nat} -> {P : Fin (S n) -> Type} -> Dec1 P -> Dec1 (tail P)
> tailDec1 dP = \x => dP (FS x)

REMARK{Nicola}{"tail restrictions of decidable predicates are
decidable". This should hold for no matter what restriction, in
fact. But we do not have a notion of subtype already and therefore we do
not have a notion of restriction.}

Next we define the base- and step-case for decidability of predicates
over |Fin n|:

> decNil : {P : Fin 0 -> Type} -> Dec (Exists P)
> decNil = No (\(Evidence wit pro)=> FinZElim wit)

We defined |decCons| to combine decidability tests for the "head" and
the "tail" of a predicate |P| into decidability for the full
predicate. (Pick the lowest index with a |Yes|.)

> using (n : Nat, P : Fin (S n) -> Type)
>   exiCons  :                    Exists (tail P)  ->      Exists P
>   exiCons (Evidence i p) = Evidence (FS i) p

>   nExiCons : Not (P FZ) -> Not (Exists (tail P)) -> Not (Exists P)
>   nExiCons n0 nt (Evidence FZ      p) = n0 p
>   nExiCons n0 nt (Evidence (FS i)  p) = nt (Evidence i p)

>   decCons  : Dec (P FZ) -> Dec (Exists (tail P)) -> Dec (Exists P)
>   decCons (Yes p) _        = Yes (Evidence FZ p)
>   decCons (No np) (Yes pt) = Yes (exiCons pt)
>   decCons (No np) (No npt) = No  (nExiCons np npt)

Find the lowest index for which |dP| says |Yes|.

> decExistsFin : (n : Nat) -> (P : Fin n -> Type) -> Dec1 P -> Dec (Exists P)
> decExistsFin Z     P dP = decNil
> decExistsFin (S n) P dP = decCons (dP FZ) (decExistsFin n (tail P)
>                                                           (tailDec1 dP))

With the simpler case out of the way we can return to the more general case:

> existsIsoTo : {X : Type} -> {Y : Type} ->
>             (iso : Iso X Y) -> (P : X -> Type) ->
>             Exists (P . (from iso)) -> Exists P
> existsIsoTo {X} {Y} iso P (Evidence y pf) = Evidence (from iso y) pf

> existsIsoFrom : {X : Type} -> {Y : Type} ->
>             (iso : Iso X Y) -> (P : X -> Type) ->
>             Exists P -> Exists (P . (from iso))
> existsIsoFrom {X} {Y} iso P (Evidence x pf) = Evidence (to iso x) pf'
>   where
>     pf' : P (from iso (to iso x))
>     pf' = replace (sym (fromTo iso x)) pf

This is the core result:

> finiteDecHelper : (n : Nat) -> {A : Type} -> FiniteN n A ->
>                   (P : A -> Type) -> Dec1 P -> Dec (Exists P)
> finiteDecHelper n iso P dP = decIso' (existsIsoTo   iso P)
>                                      (existsIsoFrom iso P)
>                                      (decExistsFin n  (P . (from iso))
>                                                       (\x => dP (from iso x)))

which can be packaged up as what we aimed for at the beginning:

> finiteDecLemma2 : {A : Type} -> {P : A -> Type} ->
>                   Finitea2 {P} (Evidence n iso) dP = finiteDecHelper n iso P dP

> ---}


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

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

sum : (single : Bool) -> isSingleton single -> Nat
sum True x = x
sum False [] = 0
sum False (x::xs) = x + sum False xs


||| Primitive operations for the Felt data type.
module Primitives.Felt

import Core.Context
import CairoCode.CairoCode
import Data.SortedSet
import Data.SortedMap
import Primitives.Common
import CommonDef
import CodeGen.CodeGenHelper

-- https://github.com/starkware-libs/cairo-lang/blob/cf8266fd5d1ff66962579ff7967ac5cdcf699f77/src/starkware/cairo/lang/cairo_constants.py
-- 2^251 + 17 * 2^192 + 1
public export
PRIME : Integer
PRIME = 3618502788666131213697322783095070105623107215331596699973092056135872020481

public export
HALF_PRIME : Integer
HALF_PRIME = PRIME `div` 2
-- 1809251394333065606848661391547535052811553607665798349986546028067936010240

-- Converts i to an integer in the range (-prime/2, prime/2) which is equivalent to val modulo prime.
-- https://github.com/starkware-libs/cairo-lang/blob/3d33c4e829a87bc3d88cf04ed6a489e788918b8b/src/starkware/cairo/lang/compiler/expression_simplifier.py#L147
export
integerToFelt : Integer -> Integer
integerToFelt i = (i + HALF_PRIME) `mod` PRIME - HALF_PRIME

-- Extended Euclidian Algorithm
-- extendedEu a PRIME computes (a^(-1),_)
extendedEu : Integer -> Integer -> (Integer, Integer)
extendedEu a 0 = (1, 0)
extendedEu a b =
  let q = a `div` b
      r = a `mod` b
      (s, t) = extendedEu b r
   in (t, s - q * t)

-- a / b
export
feltDiv : Integer -> Integer -> Integer
feltDiv a b = let (invB, _) = extendedEu b PRIME -- computes b^(-1)
                  res = (a * invB) `mod` PRIME
               in integerToFelt res

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

feltBinOp : (op: String) -> CairoReg -> List CairoReg -> LinearImplicitArgs -> PrimFnCode
feltBinOp op r [a,b] impls =
  if impls == empty
    then Raw "\{ compileRegDecl r } = \{ compileReg a } \{op} \{ compileReg b }\n"
    else assert_total $ idris_crash "no implicits expected for generateCodeBinOp: \{op}"
feltBinOp op _ _ _ = assert_total $ idris_crash "Bad arguments to feltBinOp: \{op}"

export
[add_felt] PrimFn where
    eval [_, ConstValue (F 0)] = Just $ ArgValue 0
    eval [ConstValue (F 0), _] = Just $ ArgValue 1
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (a+b)
    eval _ = Nothing

    generateCode = feltBinOp "+"

export
[sub_felt] PrimFn where
    eval [_, ConstValue (F 0)] = Just $ ArgValue 0
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (a-b)
    eval _ = Nothing

    generateCode = feltBinOp "-"

export
[mul_felt] PrimFn where
    eval [_, ConstValue (F 1)] = Just $ ArgValue 0
    eval [ConstValue (F 1), _] = Just $ ArgValue 1
    eval [_, ConstValue (F 0)] = Just $ NewValue $ ConstValue $ F 0
    eval [ConstValue (F 0), _] = Just $ NewValue $ ConstValue $ F 0
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (a*b)
    eval _ = Nothing

    generateCode = feltBinOp "*"

export
[div_felt] PrimFn where
    eval [_, ConstValue (F 0)] = Just $ Failure "Division by zero is not defined"
    eval [_, ConstValue (F 1)] = Just $ ArgValue 0
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F (feltDiv a b)
    eval _ = Nothing

    generateCode = feltBinOp "/"

export
[neg_felt] PrimFn where
    eval [ConstValue (F a)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (-a)
    eval _ = Nothing

    generateCode r [a] _ = Raw "\{ compileRegDecl r } = -\{ compileReg a }\n"
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode neg_felt"

--Todo: should we even allow this (should we have shifts in general)
export
[shl_felt] PrimFn where
    eval [_, ConstValue(F 0)] = Just $ ArgValue 0
    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (prim__shl_Integer (cast a) (cast b))
    eval _ = Nothing

    generateCode = generateMissingCodeError "shl_felt"

--Todo: should we even allow this (should we have shifts in general)
export
[shr_felt] PrimFn where
    eval [_, ConstValue(F 0)] = Just $ ArgValue 0
    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (prim__shr_Integer (cast a) (cast b))
    eval _ = Nothing

    generateCode = generateMissingCodeError "shr_felt"

-- Duplicate of UInt.and_uintX_code
and_felt_code : CairoReg -> CairoReg -> CairoReg -> CairoReg -> CairoReg -> String
and_felt_code r bitwise_ptr_in bitwise_ptr_out x y = """
    assert [\{compileReg bitwise_ptr_in}] = \{compileReg x}
    assert [\{compileReg bitwise_ptr_in}+1] = \{compileReg y}
    \{ compileRegDecl bitwise_ptr_out} = \{compileReg bitwise_ptr_in} + BitwiseBuiltin.SIZE
    \{ compileRegDecl r } = [\{compileReg bitwise_ptr_in}+2]

"""
export
[and_felt] PrimFn where
    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (prim__and_Integer (cast a) (cast b))
    eval _ = Nothing

    generateCode res [a,b] implicits =
        case lookup bitwise_builtin implicits of
            Just (bw_in, bw_out) => Raw $ and_felt_code res bw_in bw_out a b
            Nothing => assert_total $ idris_crash "bitwise_ptr not found"
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode and_felt"

-- Duplicate of UInt.or_uintX_code
or_felt_code : CairoReg -> CairoReg -> CairoReg -> CairoReg -> CairoReg -> String
or_felt_code r bitwise_ptr_in bitwise_ptr_out x y = """
    assert [\{compileReg bitwise_ptr_in}] = \{compileReg x}
    assert [\{compileReg bitwise_ptr_in}+1] = \{compileReg y}
    \{ compileRegDecl bitwise_ptr_out} = \{compileReg bitwise_ptr_in} + BitwiseBuiltin.SIZE
    \{ compileRegDecl r } = [\{compileReg bitwise_ptr_in}+4]

"""

export
[or_felt] PrimFn where
    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a),ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (prim__or_Integer (cast a) (cast b))
    eval _ = Nothing

    generateCode res [a,b] implicits =
        case lookup bitwise_builtin implicits of
                Just (bw_in, bw_out) => Raw $ or_felt_code res bw_in bw_out a b
                Nothing => assert_total $ idris_crash "bitwise_ptr not found"
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode or_felt_code"

-- Duplicate of UInt.xor_uintX_code
xor_felt_code : CairoReg -> CairoReg -> CairoReg -> CairoReg -> CairoReg -> String
xor_felt_code r bitwise_ptr_in bitwise_ptr_out x y = """
    assert [\{compileReg bitwise_ptr_in}] = \{compileReg x}
    assert [\{compileReg bitwise_ptr_in}+1] = \{compileReg y}
    \{ compileRegDecl bitwise_ptr_out} = \{compileReg bitwise_ptr_in} + BitwiseBuiltin.SIZE
    \{ compileRegDecl r } = [\{compileReg bitwise_ptr_in}+3]

"""

export
[xor_felt] PrimFn where
    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (prim__xor_Integer (cast a) (cast b))
    eval _ = Nothing

    generateCode res [a,b] implicits =
        case lookup bitwise_builtin implicits of
                Just (bw_in, bw_out) => Raw $ xor_felt_code res bw_in bw_out a b
                Nothing => assert_total $ idris_crash "bitwise_ptr not found"
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode xor_felt"

---------------------------------------------------------------------------------------------------
-- Felt LT
---------------------------------------------------------------------------------------------------
lt_felt_name : Name
lt_felt_name = makeBuiltinName "is_lt_felt"

lt_felt_code : String
lt_felt_code = """
# Checks if the unsigned integer lift (as a number in the range [0, PRIME)) of a is lower than
# that of b.
# See split_felt() for more details.
# Returns 1 if true, 0 otherwise.
func \{cairoName lt_felt_name}(range_check_ptr,a, b) -> (res, range_check_ptr):
    %{ memory[ap] = 0 if (ids.a % PRIME) < (ids.b % PRIME) else 1 %}
    jmp not_lt if [ap] != 0; ap++
    assert_lt_felt{range_check_ptr=range_check_ptr}(a, b)
    return (1, range_check_ptr)

    not_lt:
    assert_le_felt{range_check_ptr=range_check_ptr}(b, a)
    return (0, range_check_ptr)
end

"""

export
[lt_felt] PrimFn where
    apStable = False

    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ toInt (a<b)
    eval _ = Nothing

    imports = fromList [
        MkImport "starkware.cairo.common.math_cmp" "assert_lt_felt",
        MkImport "starkware.cairo.common.math_cmp" "assert_le_felt"]
    implicits = singleton range_check_builtin
    dependencies = fromList [(lt_felt_name, ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty lt_felt_code) 2 1)]
    generateCode res args implicits = Instructions [CALL [res] implicits lt_felt_name args]

---------------------------------------------------------------------------------------------------
-- Felt LTE
---------------------------------------------------------------------------------------------------
lte_felt_name : Name
lte_felt_name = makeBuiltinName "is_lte_felt"

lte_felt_code : String
lte_felt_code = """
    # Checks if the unsigned integer lift (as a number in the range [0, PRIME)) of a is lower than
    # or equal to that of b.
    # See split_felt() for more details.
    # Returns 1 if true, 0 otherwise.
    func \{cairoName lte_felt_name}(range_check_ptr, a, b) -> (res, range_check_ptr):
        %{ memory[ap] = 0 if (ids.a % PRIME) <= (ids.b % PRIME) else 1 %}
        jmp not_le if [ap] != 0; ap++
        assert_le_felt{range_check_ptr=range_check_ptr}(a, b)
        return (1, range_check_ptr)

        not_le:
        assert_lt_felt{range_check_ptr=range_check_ptr}(b, a)
        return (0, range_check_ptr)
    end

"""

export
[lte_felt] PrimFn where
    apStable = False

    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ toInt (a<=b)
    eval _ = Nothing

    imports = fromList [
        MkImport "starkware.cairo.common.math_cmp" "assert_lt_felt",
        MkImport "starkware.cairo.common.math_cmp" "assert_le_felt"]
    implicits = singleton range_check_builtin
    dependencies = fromList [(lte_felt_name, ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty lte_felt_code) 2 1)]
    generateCode res args implicits = Instructions [CALL [res] implicits lte_felt_name args]

---------------------------------------------------------------------------------------------------
-- Felt EQ
---------------------------------------------------------------------------------------------------
export
[eq_felt] PrimFn where
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ toInt (a==b)
    eval _ = Nothing

    generateCode r a i = Raw $ compileEqOp "eq_felt" r a i

---------------------------------------------------------------------------------------------------
-- Felt GTE
-- Implementation uses flipped arguments to lte
---------------------------------------------------------------------------------------------------
export
[gte_felt] PrimFn where
    apStable = False

    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ toInt (a>=b)
    eval _ = Nothing

    imports = fromList [
        MkImport "starkware.cairo.common.math_cmp" "assert_lt_felt",
        MkImport "starkware.cairo.common.math_cmp" "assert_le_felt"]
    implicits = singleton range_check_builtin
    dependencies = fromList [(lte_felt_name, ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty lte_felt_code) 2 1)]
    generateCode res [a,b] implicits = Instructions [CALL [res] implicits lte_felt_name [b,a]] -- Flipped arguments
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode gte_felt"

---------------------------------------------------------------------------------------------------
-- Felt GT
-- Implementation uses flipped arguments to lt
---------------------------------------------------------------------------------------------------
export
[gt_felt] PrimFn where
    apStable = False

    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ toInt (a>b)
    eval _ = Nothing

    imports = fromList [
        MkImport "starkware.cairo.common.math_cmp" "assert_lt_felt",
        MkImport "starkware.cairo.common.math_cmp" "assert_le_felt"]
    implicits = singleton range_check_builtin
    dependencies = fromList [(lt_felt_name, ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty lt_felt_code) 2 1)]
    generateCode res [a,b] implicits = Instructions [CALL [res] implicits lt_felt_name [b,a]] -- Flipped arguments
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode gt_felt"

-- Todo: How to treat Integers which are larger or smaller than Felt
export
[cast_to_felt] PrimFn where
    eval [ConstValue c] = map (\i => NewValue $ ConstValue $ F $ integerToFelt i) (constToInteger c)
    eval _ = Nothing

    generateCode r [a] _ = Raw "\{ compileRegDecl r } = \{ compileReg a } #Cast to felt\n"
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode cast_to_felt"


module Addition.AbsorptionLemmas

import Data.Vect
import Common.Util
import Common.Interfaces
import Specifications.DiscreteOrderedGroup
import Proofs.GroupTheory
import Addition.Carry
import public Addition.Digit

%default total
%access export

||| Express the constraint that the output is in the allowed digit
||| range.  The output range is [-v, v] before carry absorption, and
||| [-u, u] after.
public export
data Ranges : Binrel s -> (s -> s) -> s -> s -> s -> Vect k s -> Type
  where MkRanges :
    InSymRange leq neg v pending ->
    (digits : Vect k (Digit leq neg u)) ->
    Ranges leq neg u v pending (map Digit.val digits)

||| To do: prove this.
||| Need to add the assumption that One is positive.
absorbCarry : Ringops s => DiscreteOrderedGroupSpec {s} (+) Zero Ng leq One ->
  InSymRange leq Ng (u + Ng One) x ->
  (c : Carry) ->
  InSymRange leq Ng u (value c + x)

rangeLemma : Ringops s => DiscreteOrderedGroupSpec {s} (+) Zero Ng leq One ->
  Ranges leq Ng u (u + Ng One) oldPending outputs ->
  InSymRange leq Ng (u + Ng One) newPending ->
  (c : Carry) ->
  Ranges leq Ng u (u + Ng One) newPending ((value c + oldPending) :: outputs)
rangeLemma {oldPending} spec (MkRanges old digits) prf c =
  let output = value c + oldPending
      digit = MkDigit output (absorbCarry spec old c)
  in MkRanges prf (digit :: digits)


module Main

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

main : IO ()
main =
  for_ [0..9] $ \i =>
    putStrLn $ show i <+> "! = " <+> show (factorial i)


module Main

sum : Nat -> Nat
sum n = go 0 n where
  go : Nat -> Nat -> Nat
  go acc Z = acc
  go acc n@(S k) = go (acc + n) k

main : IO ()
main = printLn (sum 50000)


> module Pair.Properties

> %default total
> %access public export
> %auto_implicits off

> pairLemma : {A, B : Type} -> (ab : (A, B)) -> ab = (fst ab, snd ab)
> pairLemma (a, b) = Refl

> pairEqElimFst : {A, B : Type} -> {a, a' : A} -> {b, b' : B} -> (a, b) = (a', b') -> a = a'
> pairEqElimFst Refl = Refl

> pairEqElimSnd : {A, B : Type} -> {a, a' : A} -> {b, b' : B} -> (a, b) = (a', b') -> b = b'
> pairEqElimSnd Refl = Refl


module Main

tarai : Int -> Int -> Int -> Int
tarai x y z = if x <= y
	then y
	else tarai (tarai (x - 1) y z) (tarai (y - 1) z x) (tarai (z - 1) x y)

main : JS_IO ()
main = do
	putStr' $ show (tarai 11 5 0)


module Verified.Applicative.Vect

import Data.Vect
import Verified.Applicative
import Verified.Functor
import Verified.Functor.Vect

applicativeMap_Vect : (vs : Vect n a) -> (g : a -> b) -> map g vs = pure g <*> vs
applicativeMap_Vect []        g = Refl
applicativeMap_Vect (v :: vs) g = rewrite (applicativeMap_Vect vs g) in Refl

applicativeIdentity_Vect : (vs : Vect n a) -> pure id <*> vs = vs
applicativeIdentity_Vect []        = Refl
applicativeIdentity_Vect (x :: xs) = rewrite (applicativeIdentity_Vect xs) in Refl

applicativeInterchange_Vect : (x : a) -> (g : Vect n (a -> b)) -> g <*> pure x = pure (\g' => g' x) <*> g
applicativeInterchange_Vect x []        = Refl
applicativeInterchange_Vect x (f :: fs) = rewrite (applicativeInterchange_Vect x fs) in Refl

applicativeComposition_Vect : (xs : Vect n a) -> (g1 : Vect n (a -> b)) -> (g2 : Vect n (b -> c))
                           -> pure (.) <*> g2 <*> g1 <*> xs = g2 <*> (g1 <*> xs)
applicativeComposition_Vect []        []          []          = Refl
applicativeComposition_Vect (v :: vs) (g1 :: g1s) (g2 :: g2s) = rewrite (applicativeComposition_Vect vs g1s g2s) in Refl

applicativeHomomorphism_Vect : {n : Nat} -> (x : a) -> (g : a -> b)
                            -- pure g <*> pure x = pure (g x)
                            -> Vect.zipWith apply (Vect.replicate n g) (Vect.replicate n x) = Vect.replicate n (g x)
applicativeHomomorphism_Vect {n =    Z } x g = Refl
applicativeHomomorphism_Vect {n = (S k)} x g = rewrite (applicativeHomomorphism_Vect x g {n=k}) in Refl

instance VerifiedApplicative (Vect vlen) where
  applicativeMap = applicativeMap_Vect
  applicativeIdentity = applicativeIdentity_Vect
  applicativeInterchange = applicativeInterchange_Vect
  applicativeComposition = applicativeComposition_Vect
  applicativeHomomorphism = applicativeHomomorphism_Vect


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

-- check that all functions are total
%default total

--
-- Expressions
--

||| An integer arithmetic expression
data Expr = ||| A single integer
            Value Int
          | ||| Addition of an expression to an expression
            Addition Expr Expr
          | ||| Subtraction of an expression from an expression
            Subtraction Expr Expr
          | ||| Multiplication of an expression with an expression
            Multiplication Expr Expr

||| Evaluate an expression
evaluate : Expr -> Int
evaluate (Value x) = x
evaluate (Addition x y) = evaluate x + evaluate y
evaluate (Subtraction x y) = evaluate x - evaluate y
evaluate (Multiplication x y) = evaluate x * evaluate y


module ex_3_2_4

import Data.Vect

-- interactive editing mode
-- ctrl+alt+a
-- ctrl+alt+c
-- ctrl+alt+l
-- ctrl+alt+s

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

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

length' : List a -> Nat
length' [] = 0
length' (x :: xs) = S $ length' xs

-- *ex_3_2_4> length' []
-- (input):Can't infer argument a to length', Can't infer argument a to []
-- Can't infer argument
-- need explicit type, using `the`
-- *ex_3_2_4> length' $ the (List Int) []
-- 0 : Nat

reverse' : List a -> List a
reverse' [] = []
reverse' (x :: xs) = reverse' xs ++ [x]

-- *ex_3_2_4> reverse' [1,2,3]
-- [3, 2, 1] : List Integer


module Decidable.Equality

import Data.Maybe
import Data.Either
import Data.Nat
import Data.List
import Data.List1

import public Decidable.Equality.Core as Decidable.Equality

%default total

--------------------------------------------------------------------------------
--- Unit
--------------------------------------------------------------------------------

public export
DecEq () where
  decEq () () = Yes Refl

--------------------------------------------------------------------------------
-- Booleans
--------------------------------------------------------------------------------

public export
DecEq Bool where
  decEq True  True  = Yes Refl
  decEq False False = Yes Refl
  decEq False True  = No absurd
  decEq True  False = No absurd

--------------------------------------------------------------------------------
-- Nat
--------------------------------------------------------------------------------

public export
DecEq Nat where
  decEq Z     Z     = Yes Refl
  decEq Z     (S _) = No absurd
  decEq (S _) Z     = No absurd
  decEq (S n) (S m) with (decEq n m)
   decEq (S n) (S m) | Yes p = Yes $ cong S p
   decEq (S n) (S m) | No p = No $ \h : (S n = S m) => p $ succInjective n m h

--------------------------------------------------------------------------------
-- Maybe
--------------------------------------------------------------------------------

public export
DecEq t => DecEq (Maybe t) where
  decEq Nothing Nothing = Yes Refl
  decEq Nothing (Just _) = No absurd
  decEq (Just _) Nothing = No absurd
  decEq (Just x') (Just y') with (decEq x' y')
    decEq (Just x') (Just y') | Yes p = Yes $ cong Just p
    decEq (Just x') (Just y') | No p
       = No $ \h : Just x' = Just y' => p $ justInjective h

--------------------------------------------------------------------------------
-- Either
--------------------------------------------------------------------------------

public export
(DecEq t, DecEq s) => DecEq (Either t s) where
  decEq (Left x) (Left y) with (decEq x y)
   decEq (Left x) (Left x) | Yes Refl = Yes Refl
   decEq (Left x) (Left y) | No contra = No (contra . leftInjective)
  decEq (Left x) (Right y) = No absurd
  decEq (Right x) (Left y) = No absurd
  decEq (Right x) (Right y) with (decEq x y)
   decEq (Right x) (Right x) | Yes Refl = Yes Refl
   decEq (Right x) (Right y) | No contra = No (contra . rightInjective)

--------------------------------------------------------------------------------
-- Tuple
--------------------------------------------------------------------------------

pairInjective : (a, b) = (c, d) -> (a = c, b = d)
pairInjective Refl = (Refl, Refl)

public export
(DecEq a, DecEq b) => DecEq (a, b) where
  decEq (a, b) (a', b') with (decEq a a')
    decEq (a, b) (a', b') | (No contra) =
      No $ contra . fst . pairInjective
    decEq (a, b) (a, b') | (Yes Refl) with (decEq b b')
      decEq (a, b) (a, b) | (Yes Refl) | (Yes Refl) = Yes Refl
      decEq (a, b) (a, b') | (Yes Refl) | (No contra) =
        No $ contra . snd . pairInjective

--------------------------------------------------------------------------------
-- List
--------------------------------------------------------------------------------

public export
DecEq a => DecEq (List a) where
  decEq [] [] = Yes Refl
  decEq (x :: xs) [] = No absurd
  decEq [] (x :: xs) = No absurd
  decEq (x :: xs) (y :: ys) with (decEq x y)
    decEq (x :: xs) (y :: ys) | No contra =
      No $ contra . fst . consInjective
    decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys)
      decEq (x :: xs) (x :: xs) | (Yes Refl) | (Yes Refl) = Yes Refl
      decEq (x :: xs) (x :: ys) | (Yes Refl) | (No contra) =
        No $ contra . snd . consInjective

--------------------------------------------------------------------------------
-- List1
--------------------------------------------------------------------------------

public export
DecEq a => DecEq (List1 a) where

  decEq (x ::: xs) (y ::: ys) with (decEq x y)
    decEq (x ::: xs) (y ::: ys) | No contra = No (contra . fst . consInjective)
    decEq (x ::: xs) (y ::: ys) | Yes eqxy with (decEq xs ys)
      decEq (x ::: xs) (y ::: ys) | Yes eqxy | No contra = No (contra . snd . consInjective)
      decEq (x ::: xs) (y ::: ys) | Yes eqxy | Yes eqxsys = Yes (cong2 (:::) eqxy eqxsys)

-- TODO: Other prelude data types

-- For the primitives, we have to cheat because we don't have access to their
-- internal implementations. We use believe_me for the inequality proofs
-- because we don't them to reduce (and they should never be needed anyway...)
-- A postulate would be better, but erasure analysis may think they're needed
-- for computation in a higher order setting.

--------------------------------------------------------------------------------
-- Int
--------------------------------------------------------------------------------
public export
implementation DecEq Int where
    decEq x y = case x == y of -- Blocks if x or y not concrete
                     True => Yes primitiveEq
                     False => No primitiveNotEq
       where primitiveEq : forall x, y . x = y
             primitiveEq = believe_me (Refl {x})
             primitiveNotEq : forall x, y . Not (x = y)
             primitiveNotEq prf = believe_me {b = Void} ()

--------------------------------------------------------------------------------
-- Char
--------------------------------------------------------------------------------
public export
implementation DecEq Char where
    decEq x y = case x == y of -- Blocks if x or y not concrete
                     True => Yes primitiveEq
                     False => No primitiveNotEq
       where primitiveEq : forall x, y . x = y
             primitiveEq = believe_me (Refl {x})
             primitiveNotEq : forall x, y . Not (x = y)
             primitiveNotEq prf = believe_me {b = Void} ()

--------------------------------------------------------------------------------
-- Integer
--------------------------------------------------------------------------------
public export
implementation DecEq Integer where
    decEq x y = case x == y of -- Blocks if x or y not concrete
                     True => Yes primitiveEq
                     False => No primitiveNotEq
       where primitiveEq : forall x, y . x = y
             primitiveEq = believe_me (Refl {x})
             primitiveNotEq : forall x, y . Not (x = y)
             primitiveNotEq prf = believe_me {b = Void} ()

--------------------------------------------------------------------------------
-- String
--------------------------------------------------------------------------------
public export
implementation DecEq String where
    decEq x y = case x == y of -- Blocks if x or y not concrete
                     True => Yes primitiveEq
                     False => No primitiveNotEq
       where primitiveEq : forall x, y . x = y
             primitiveEq = believe_me (Refl {x})
             primitiveNotEq : forall x, y . Not (x = y)
             primitiveNotEq prf = believe_me {b = Void} ()


module AlterningBitsOracle

import Data.Nat
import Unitary
import Lemmas

%default total

|||Alternating bits oracle : checks if the input alternates, i-e does not have a pair of adjacent qubits in stae 00 or 11

lemmaFlip : (i : Nat) -> (k : Nat) -> (p : S (S i) < k = True) -> i < k = True
lemmaFlip 0 k p = lemmaCompLT0 k 2
lemmaFlip (S i) (S k) p = lemmaFlip i k p

lemmaSolve : (n : Nat) -> n < S (S n) = True
lemmaSolve 0 = Refl
lemmaSolve (S k) = lemmaSolve k

flip : (n : Nat) -> (i : Nat) -> {auto prf : i < S (S n) = True} -> Unitary (S (S n))
flip n 0 = X 0 IdGate
flip n 1 = X 1 IdGate
flip n (S (S i)) = X (S (S i)) (flip n i {prf = lemmaFlip i (S (S n)) prf})

export
solve : (n : Nat) -> Unitary ((S (S n)) + 1)
solve n =
  let circ1 = (flip n (S n) {prf = lemmaLTSucc n}) # IdGate {n=1}
      circ2 = flip n n {prf = lemmaSolve n} # IdGate {n = 1}
      circ1' = circ1 . multipleQubitControlledNOT ((S (S n)) + 1) . circ1
      circ2' = circ2 . multipleQubitControlledNOT ((S (S n)) + 1) . circ2
  in circ1' . circ2'


module Rationals

import ZZ

%access public export

Pair : Type
Pair = (Integer, Integer)

ZZPair : Type
ZZPair = (ZZ, ZZ)

ZZtoDb : ZZ -> Double
ZZtoDb x = cast{from=Integer}{to=Double} (cast{from=ZZ}{to=Integer} x)

DbtoZZ : Double -> ZZ
DbtoZZ x = cast{from=Integer}{to=ZZ} (cast{from=Double}{to=Integer} x)

apZZ : (f: ZZ -> ZZ) -> (n: ZZ) -> (m: ZZ) -> n = m -> f n = f m
apZZ f m m Refl = Refl

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

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

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

--Integer implemetation of gcd
CalcGCD : (Integer, Integer) -> Integer
CalcGCD (a, b) = if (isNotZero (toNat b)) then next else a where
    next = CalcGCD (b, toIntegerNat (modNat (toNat a) (toNat b)))

OnlyPositive : (x: Pair) -> Pair
OnlyPositive x = (if (fst x)>0 then fst x else (-1)*(fst x), if(snd x)>0 then (snd x) else (-1)*(snd x))

--Integer implemetation of gcd
gccd : (Integer, Integer) -> Integer
gccd x = CalcGCD (OnlyPositive x)

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

data ZZNotZero : ZZ -> Type where
  ZZOneNotZero : ZZNotZero 1
  ZZNegativeNotZero : ( n: ZZ ) -> ZZNotZero n -> ZZNotZero (-n)
  ZZPositiveNotZero : ( m: ZZ ) -> LTE 1 (fromIntegerNat (cast(m)))  -> ZZNotZero m

--Type for equality of two Rationals
data EqRat : Pair -> Pair -> Type where
  IdEq : (m : Pair) -> EqRat m m
  MulEq : (c : Integer) -> EqRat n m -> EqRat ((fst n)*c,(snd n)*c) m

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

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

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

MultiplyRationals : (x: ZZPair) -> ZZNotZero (snd x) -> (y: ZZPair) -> ZZNotZero (snd y) -> ZZPair
MultiplyRationals x a y b =((fst x)*(fst y), (snd x)*(snd y))

MultInverse : (x: ZZPair) -> ZZNotZero (fst x) -> ZZNotZero (snd x) -> ZZPair
MultInverse x y z = ((snd x), (fst x))

AddInverse : (x: ZZPair) -> ZZNotZero (snd x) -> ZZPair
AddInverse x a = (-(fst x), (snd x))

Subtraction : (x: ZZPair) -> ZZNotZero (snd x) -> (y: ZZPair) -> ZZNotZero (snd y) -> ZZPair
Subtraction x a y b = AddRationals x a (AddInverse y b) b

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

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

--To prove that the SimplifyRational works, we can just check if the output is equal to the input
-- To be done

simplifyRational : (x : ZZPair) -> ZZPair
simplifyRational (a, b) = (sa, sb) where
  sa = DbtoZZ (da / g) where
    da = ZZtoDb a
    g = cast {from=Integer} {to=Double}
      (gccd (cast {from=ZZ} {to=Integer}a,cast {from=ZZ} {to=Integer}b))
  sb = DbtoZZ (db / g) where
    db = ZZtoDb b
    g = cast {from=Integer} {to=Double}
      (gccd (cast {from=ZZ} {to=Integer}a,cast {from=ZZ} {to=Integer}b))

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

xAndInverseNotZero : (x: ZZPair) -> (k: ZZNotZero (snd x)) -> ZZNotZero (snd (AddInverse x k))
xAndInverseNotZero x (ZZPositiveNotZero (snd x) y) = (ZZPositiveNotZero (snd x) y)

FirstIsInverted : (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (a: ZZ) -> (a = (fst x)) -> ((-a) = fst (AddInverse x k))
FirstIsInverted x k a prf = (apZZ (\x => -x) a (fst x) prf)

SecondStaysSame : (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (b: ZZ) -> (b = (snd x)) -> (b = (snd (AddInverse x k)))
SecondStaysSame x k b prf = (apZZ (\x => x) b (snd x) prf)

xplusinverse: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> ZZPair
xplusinverse x k = AddRationals x k (AddInverse x k) (xAndInverseNotZero x k)

addinverselemma: (a: ZZ) -> (b: ZZ) -> ((-a)=b) -> (a + b = ((-a) + a)) -> ((-a)+a =0 ) -> (a + b = 0)
addinverselemma a b prf prf1 prf2 = trans prf1 prf2

addinverseFST: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (a: ZZ) -> (a = (fst x)) -> (fst (AddInverse x k) = b) -> ((-a) = b)
addinverseFST x k a prf prf1 = trans (FirstIsInverted x k a prf) (prf1)

addinverseSND: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (c: ZZ) -> (c = (snd x)) -> (snd (AddInverse x k) = b) -> (c = b)
addinverseSND x k c prf prf1 = trans (SecondStaysSame x k c prf) (prf1)


module Sub13LTE108t75

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total

-- 6(18t+12)+3 --AB[6,-3,-2]--> 6(4t+1)+3
export
lte108t75 : (l : Nat) -> LTE (S (S (plus (plus l l) (plus l l)))) (S (S (S ((S ((S (l+l+l))+(S (l+l+l)))) + (S ((S (l+l+l))+(S (l+l+l)))) + (S ((S (l+l+l))+(S (l+l+l))))))))
lte108t75 Z     = (lteSuccRight . LTESucc . LTESucc) LTEZero
lte108t75 (S l) =
  let lemma = lte108t75 l in
  rewrite (sym (plusSuccRightSucc l l)) in
  rewrite (sym (plusSuccRightSucc (plus l l) l)) in

  rewrite (sym (plusSuccRightSucc (plus l l) (S (plus l l)))) in
  rewrite (sym (plusSuccRightSucc (plus l l)    (plus l l))) in

  rewrite (sym (plusSuccRightSucc (plus (plus l l) l) (S (S (S (plus (plus l l) l)))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)    (S (S (plus (plus l l) l))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)       (S (plus (plus l l) l)))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l)))    (S (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l)))       (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l)))          (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l)))             (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l)))                (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))) (S (S (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))    (S (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))       (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))          (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))             (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))                (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))) in
    (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc) lemma


t1 : Bits8
t1 = 2

t2 : Bits8
t2 = 255

t3 : Bits8
t3 = 100

tests8 : List String
tests8 = map show [t1 + t2,
                   t1 * t3,
                   the Bits8 (fromInteger (-8)),
                   the Bits8 257,
                   the Bits8 (fromInteger (-1)),
                   prim__shl_Bits8 t3 1,
                   prim__shl_Bits8 t2 1]

testsCmp : List String
testsCmp = map show [t1 < t2, t3 < (t2 + t1)]

testsMax : List String
testsMax = [show (the Bits8 (fromInteger (-1))),
            show (the Bits16 (fromInteger (-1))),
            show (the Bits32 (fromInteger (-1))),
            show (the Bits64 (fromInteger (-1)))]

main : IO ()
main
    = do printLn (t1 + t2)
         printLn (t1 * t3)
         printLn (t1 < t2)
         printLn (prim__shl_Bits8 t3 1)
         printLn (prim__shl_Bits8 t2 1)
         printLn (t3 < (t2 + t1))
         printLn (the Bits8 (fromInteger (-8)))
         printLn (the Bits8 257)
         printLn (the Bits64 1234567890)
         printLn (the Bits8 (fromInteger (-1)))
         printLn (the Bits16 (fromInteger (-1)))
         printLn (the Bits32 (fromInteger (-1)))
         printLn (the Bits64 (fromInteger (-1)))