module Control.Algebra.ZZBezoutsIdentity

import Control.Algebra
import Classes.Verified

import Data.ZZ
import Control.Algebra.NumericInstances
import Control.Algebra.ZZVerifiedInstances
import Data.Matrix.AlgebraicVerified 	-- for (ringNeutralIsMultZeroL)

import Control.Algebra.ZZDivisors

import Data.Fin.FinOrdering
import Data.Fin.Structural

import Control.Isomorphism

-- Dependent pattern matching using (do) notation binds improves clarity
import Control.Monad.Identity
import Syntax.PreorderReasoning

import Control.Algebra.DiamondInstances

-- For example
import Data.ZZ.ZZModulo

{-
Table of contents:
* Lemmas for verifying the euclidean algorithm (bezoutsIdentityZZIfModulo)
* (bezoutsIdentityZZIfModulo) implementation
* (Commentary) "Goal: Separation of algorithm from verification."
* The GCD derived from (modZT), itself derived from (modNatT).
-}

{-
Lemmas for verifying the euclidean algorithm (bezoutsIdentityZZIfModulo)
-}

total
bezoutsIdentityLincombEqZZ :
	(a, b, c, d, q, r : ZZ)
	-> q<.>d = c <-> r
	-> b<.>c <+> (a <-> b <.> q)<.>d
		= a<.>d <+> b<.>r
bezoutsIdentityLincombEqZZ a b c d q r pr =
	(
	b<.>c <+> (a <-> b <.> q)<.>d
	) ={
		cong {f=((b<.>c) <+>)}
		$ (
		(a <-> b <.> q)<.>d
		) ={ ringOpIsDistributiveSubR _ _ _ }= (
		a<.>d <-> (b<.>q)<.>d
		) ={
			cong {f=((a<.>d) <->)}
			{- Bracketing style switch -}
			$ ( b<.>q<.>d ) ={ sym $ ringOpIsAssociative b q d }=
			( b<.>(q<.>d) ) ={ cong {f=(b<.>)} pr }=
			( b<.>(c <-> r) ) QED
			}= (
		a<.>d <-> b<.>(c <-> r)
		) ={ abelianGroupOpIsCommutative (a <.> d) _ }= (
		(inverse $ b<.>(c <-> r)) <+> a <.> d
		) QED
		}= (
	b <.> c <+> ( (inverse $ b<.>(c <-> r)) <+> a <.> d )
	) ={ semigroupOpIsAssociative _ _ _ }= (
	b <.> c <-> b<.>(c <-> r) <+> a <.> d
	) ={ abelianGroupOpIsCommutative _ (a <.> d) }= (
	a <.> d <+> ( b <.> c <-> b<.>(c <-> r) )
	) ={
		cong {f=((a <.> d) <+>)}
		$ trans (sym $ ringOpIsDistributiveSubL _ _ _)
		$ cong {f=(b<.>)}
		{- Bracketing style switch -}
		$ ( c <-> (c <-> r) )
			={
				cong {f=(c<+>)}
				$ trans (ringOpIsDistributiveR _ _ _)
				$ cong {f=((inverse c) <+>)}
				$ inverseIsInvolution r
				}=
		( c <+> (inverse c <+> r) )
			={ semigroupOpIsAssociative c (inverse c) r }=
		( (c <-> c) <+> r )
			={ cong {f=(<+> r)} $ groupInverseIsInverseL c }=
		( Algebra.neutral <+> r )
			={ monoidNeutralIsNeutralR _ }=
		( r ) QED
		}= (
	a<.>d <+> b<.>r
	) QED

total
bezoutsIdentityExtQuotientLincombZZ :
	(c, d, q, r, x : ZZ)
	-> (q<.>d <+> r = c)
	-> (d `quotientOverZZ` x)
	-> (r `quotientOverZZ` x)
	-> (c `quotientOverZZ` x)
bezoutsIdentityExtQuotientLincombZZ c d q r x eqpr (dq ** dqPr) (rq ** rqPr)
	= (q<.>dq <+> rq
	** trans (ringOpIsDistributiveR (q<.>dq) rq x)
	$ rewrite rqPr
	in trans ( cong { f= (<+>r) }
		$ trans (sym $ ringOpIsAssociative _ _ _)
		$ cong {f=(q<.>)} $ dqPr )
	$ eqpr)

total
bezQTy : (c, d, a, b : ZZ) -> Type
bezQTy c d a b =
	( c `quotientOverZZ` (a<.>c <+> b<.>d)
	, d `quotientOverZZ` (a<.>c <+> b<.>d) )

{-
(bezoutsIdentityZZIfModulo) implementation

Given a modulo operator giving the remainder in a remainder-division pair,
produce a linear combination of two input integers which divides them both.

Since every number dividing both integers divides every linear combination
of them, this gives the greatest common denominator.

The latter statement isn't proved here, though.
-}

{- (bezoutsIdentityZZIfModulo) parameters -}
parameters (
	{-
	The nonnegative residue of the 1st modulo the subgroup generated by the 2nd.
	Can factor through a modulo on naturals, but must be everywhere defined.
	-}
	modZ : ZZ -> ZZ -> ZZ
	, quotientPartZ : (x, m : ZZ) -> (x <-> modZ x m) `quotientOverZZ` m
	) {

bezoutsIdentityZZIfModulo :
	( c, d : ZZ )
	-> ( zpar : (ZZ, ZZ) ** uncurry (bezQTy c d) zpar )
-- bezoutsIdentityZZIfModulo c (Pos Z) = ( (1, 0) ** ((1 ** _), (0 ** _)) )
bezoutsIdentityZZIfModulo c (Pos Z) = ( (Algebra.unity, Algebra.neutral)
	** rewrite ringWithUnityIsUnityR c
		in rewrite monoidNeutralIsNeutralL c
		in ( (Algebra.unity ** ringWithUnityIsUnityR c)
			, (Algebra.neutral ** ringNeutralIsMultZeroL c) ) )
bezoutsIdentityZZIfModulo c d with (bezoutsIdentityZZIfModulo d (c `modZ` d))
	| ((a,b) ** oldpr) = runIdentity $ do {
			(q ** qIsDivD) <- Id $ c `quotientPartZ` d
			((a' ** divsPrA), (b' ** divsPrB)) <- Id $ oldpr
			-- reverifyDivZ across the bind
			let reverifyDivZ' =
				trans (cong {f=(<+> (c `modZ` d))} qIsDivD)
				$ groupSubtractionIsRDivision c $ c `modZ` d
			-- the goal linear combo of c & d gives d `gcd` (c `modZ` d)
			let lincombEq = bezoutsIdentityLincombEqZZ
				a b c d q (c `modZ` d)
				$ groupDivisionAddLToSubR
					(q <.> d) (c `modZ` d) c
					$ reverifyDivZ'
			-- d `gcd` (c `modZ` d) | c
			let extQuotientLincombZZ = bezoutsIdentityExtQuotientLincombZZ
				c d q (c `modZ` d) ( a<.>d <+> b<.>(c `modZ` d) )
				reverifyDivZ'
				(a' ** divsPrA)
				(b' ** divsPrB)
			return $ ( (b, a <-> b <.> q)
				** ((getWitness extQuotientLincombZZ
					** trans (cong lincombEq)
					$ getProof extQuotientLincombZZ)
				, (a' ** trans (cong lincombEq) divsPrA)) )
		}

} {- (bezoutsIdentityZZIfModulo) parameters -}

{-
Goal: Separation of algorithm from verification.
Obstructions: (Problem 1), (Problem 2).

divZ : ZZ -> ZZ -> ZZ
divZ a b = getWitness $ quotientPartZ a b

reverifyDivZ : divZ a b <.> b <+> modZ a b = a
reverifyDivZ {a} {b}
	= trans (cong {f=(<+> (a `modZ` b))}
		$ getProof $ quotientPartZ a b)
	$ groupSubtractionIsRDivision a $ a `modZ` b

||| Greatest Common Denominator (GCD) linear combination factors
euclideanAlgPar : ZZ -> ZZ -> (ZZ, ZZ)
euclideanAlgPar c (Pos Z) = (1, 0)
euclideanAlgPar c d = (b, a <-> b <.> q)
	where
		eucParReduced : (ZZ, ZZ)
		eucParReduced = euclideanAlgPar d (c `modZ` d)
		a : ZZ
		a = fst eucParReduced
		b : ZZ
		b = snd eucParReduced
		q : ZZ
		q = c `divZ` d

||| Greatest Common Denominator (GCD)
euclideanAlg : ZZ -> ZZ -> ZZ
euclideanAlg c d = let (a, b) = euclideanAlgPar c d in a<.>c <+> b<.>d

bezoutsIdentity : (c, d : ZZ) -> uncurry (bezQTy c d) $ euclideanAlgPar c d

---
Problem 1)
rewrite did not change type uncurry (bezQTy c (Pos 0)) (euclideanAlgPar c (Pos 0))
---

bezoutsIdentity c (Pos Z)
	= rewrite ringWithUnityIsUnityR c
	in rewrite monoidNeutralIsNeutralL c
	in ( (Algebra.unity ** ringWithUnityIsUnityR c)
		, (Algebra.neutral ** ringNeutralIsMultZeroL c) )

---
Problem 2)
Proof must be repeated for positive and negative halves,
since otherwise the case can't be determined to not be the one for 2nd argument 0.
---

bezoutsIdentity c d@(Pos $ S d') = ?bezoutsIdentity_rhs_2
bezoutsIdentity c d@(NegS d') = ?bezoutsIdentity_rhs_3

-}

{-
The GCD derived from (modZT), itself derived from (modNatT).
-}

bezoutZT :
	( c, d : ZZ )
	-> ( zpar : (ZZ, ZZ) ** uncurry (bezQTy c d) zpar )
bezoutZT = bezoutsIdentityZZIfModulo modZT quotientPartModZT


{-
0.42
1.68
1.34
0.34
42
0
-}
module Main

testNum : IO ()
testNum =
  traverse_
    (\op => printLn $ 0.84 `op` 0.5)
    [(*), (/), (+), (-)]

testStr : IO ()
testStr =
  for_ ["42.0", "not a double"] $ \s =>
    printLn $ the Double (cast s)

main : IO ()
main = do
  testNum
  testStr


module Data.Fin.Structural

import Data.Fin
import Data.ZZ
import Control.Isomorphism

import Data.Fin.FinOrdering

%default total

{-
Structure of (Fin)s
* in general
* in terms of ordering
-}

ltePredLeft : LTE (S n) m -> LTE n m
ltePredLeft = fromLteSucc . lteSuccRight

gtnatFZImpliesIsFinSucc :
	(nel : Fin (S nu))
	-> (LTRel Z $ finToNat nel)
	-> (prednel : Fin nu ** nel = FS prednel)
gtnatFZImpliesIsFinSucc FZ ltpr = void $ succNotLTEzero ltpr
gtnatFZImpliesIsFinSucc (FS prednel) ltpr = (prednel ** Refl)

trichotomy : (n,m : Nat) -> Either (n `LT` m) $ Either (n = m) (m `LT` n)
trichotomy Z Z = Right $ Left Refl
trichotomy (S predn) Z = Right $ Right $ zLtSuccIsTrue predn
trichotomy Z (S predm) = Left $ zLtSuccIsTrue predm
trichotomy (S predn) (S predm)
	= either ( Left . LTESucc )
		( Right . either (Left . cong) (Right . LTESucc) )
	$ trichotomy predn predm

||| See (trichotomy)
eqOrGTToLT :
	Either (n = m) (LT m n)
	-> LTE m n
eqOrGTToLT = lteRelToLTE . either (Right . sym) Left

||| Allows: under decEq : (-) {smaller=notLTToGTE notlt}
notLTToGTE : Not (LT a b) -> LTE b a
notLTToGTE {a} {b} nonpr = eqOrGTToLT
	$ either (void . nonpr) id
	$ trichotomy a b

total
FinSZAreFZ : (x : Fin 1) -> x=FZ
FinSZAreFZ FZ = Refl
FinSZAreFZ (FS voda) = FinZElim voda

commuteFSWeaken : (i : Fin n) -> (FS $ weaken i = weaken $ FS i)
commuteFSWeaken i = Refl

{-
"
LTE (S (finToNat last)) (finToNat i)  cannot be a parameter of Prelude.Uninhabited.Uninhabited
(Type class arguments must be injective)
"

> instance Uninhabited (LTE (S $ finToNat $ last {n=n}) (finToNat $ the (Fin (S n)) i)) where {
> 	uninhabited = ?notSNatLastLTEAnything
> }
-}

-- notSNatLastLTEAnything : LTE (S $ finToNat $ last {n=n}) (finToNat $ the (Fin (S n)) i) -> Void

total
notSNatLastLTEAnything : {n : Nat} -> {i : Fin (S n)} -> LTE (S $ finToNat $ last {n=n}) (finToNat i) -> Void
notSNatLastLTEAnything {n} {i=FZ} = uninhabited
notSNatLastLTEAnything {n=Z} {i=FS pri} = FinZElim pri
notSNatLastLTEAnything {n=S predn} {i=FS pri} = notSNatLastLTEAnything . fromLteSucc

finToNatWeaken : {k : Fin n} -> finToNat k = finToNat (weaken k)
finToNatWeaken {k=FZ} = Refl
finToNatWeaken {k=FS k} = cong {f=S} $ finToNatWeaken {k}

partitionNatWknLT : (pnel : Fin n) -> (el : Fin (S n)) -> (elDown : LTRel (finToNat $ weaken pnel) (finToNat el)) -> Either ( LTRel (finToNat $ FS pnel) (finToNat el) ) ( el=FS pnel )
partitionNatWknLT pnel el elDown = map (sym . (finToNatInjective (FS pnel) el)) $ lteToLTERel $ lteFromEqLeft (cong {f=S} $ sym finToNatWeaken) elDown
	where
		lteFromEqLeft : (a=b) -> LTE a c -> LTE b c
		lteFromEqLeft pr lel = rewrite (sym pr) in lel

total
splitFinS : (i : Fin (S predn)) -> Either ( k : Fin predn ** i = weaken k ) ( i = Data.Fin.last )
splitFinS {predn=Z} FZ = Right Refl
splitFinS {predn=Z} (FS j) = absurd j
splitFinS {predn=S prededn} FZ = Left ( FZ ** Refl )
splitFinS {predn=S prededn} (FS prednel) with ( splitFinS prednel )
	| Left ( k ** pr ) = Left ( FS k ** cong pr )
	| Right pr = Right $ cong pr

wknLTLast : (a : Fin n) -> LT (finToNat $ weaken a) (finToNat $ last {n=n})
wknLTLast FZ = zLtSuccIsTrue _
wknLTLast (FS k) = LTESucc $ wknLTLast k

ltenatLastIsTrue2 : (i : Fin (S nu)) -> LTERel (finToNat i) $ finToNat $ last {n=nu}
ltenatLastIsTrue2 FZ {nu=Z} = Right Refl
ltenatLastIsTrue2 (FS k) {nu=Z} = absurd k
ltenatLastIsTrue2 i {nu=S prednu} with (splitFinS i)
	| Left (k ** prwkn) = Left $ rewrite prwkn in wknLTLast {n=S prednu} k
	| Right prLast = Right $ cong {f=finToNat} prLast

{- (ltenatLastIsTrue) subsection -}

notLTSelf : Not (LT a a)
notLTSelf {a=Z} = succNotLTEzero
notLTSelf {a=S preda} = notLTSelf . fromLteSucc

lteUnique : {a, b : Nat} -> (x, y : LTERel a b) -> x = y
lteUnique (Left LTEZero) (Left LTEZero) impossible
lteUnique (Left LTEZero) (Left (LTESucc ltY)) impossible
lteUnique (Left (LTESucc ltX)) (Left LTEZero) impossible
lteUnique (Left (LTESucc ltX)) (Left (LTESucc ltY)) {b=Z} impossible
lteUnique (Left (LTESucc LTEZero)) (Left (LTESucc LTEZero)) {a=Z} {b=S right} = Refl
lteUnique (Left (LTESucc ltX)) (Left (LTESucc ltY)) {a=S left} {b=S right}
	with (lteUnique (Left ltX) (Left ltY))
	| prEq = cong {f=Left . LTESucc} $ leftInjective prEq
lteUnique (Left ltX) (Right prEq) {b}
	= void $ notLTSelf $ replace prEq {P=\x => LT x b} ltX
lteUnique (Right prEq) (Left ltY) {b}
	= void $ notLTSelf $ replace prEq {P=\x => LT x b} ltY
lteUnique (Right Refl) (Right Refl) = Refl
lteUnique (Right Refl) (Right Refl) {a=Z} {b = S right} impossible
lteUnique (Right Refl) (Right Refl) {a = S left} {b=Z} impossible

ltenatLastIsTrue : Iso (nel : Fin (S nu) ** LTERel (finToNat nel) $ finToNat $ last {n=nu}) $ Fin (S nu)
ltenatLastIsTrue = MkIso
	getWitness
	(\nel => (nel ** ltenatLastIsTrue2 nel))
	(\y => Refl)
	ltenatLastIsTrue_fromTo
	where
		ltenatLastIsTrue_fromTo :
			(x : (nel : Fin (S nu)
				** LTERel (finToNat nel) $ finToNat $ last {n=nu}))
			-> (getWitness x ** ltenatLastIsTrue2 (getWitness x)) = x
		ltenatLastIsTrue_fromTo (nel ** ltepr)
			= rewrite sameLTEPr in Refl
			where
				sameLTEPr : ltenatLastIsTrue2 nel = ltepr
				sameLTEPr = lteUnique (ltenatLastIsTrue2 nel) ltepr

{-
Nat algebraic theorems
-}

lteUnsumLeftSummandRight : (x `plus` y) `LT` z -> y `LT` z
lteUnsumLeftSummandRight {x=Z} = id
lteUnsumLeftSummandRight {x=S predx} = lteUnsumLeftSummandRight . ltePredLeft

lteUnsumLeftSummandLeft : (x `plus` y) `LT` z -> x `LT` z
lteUnsumLeftSummandLeft {x} {y} = rewrite (plusCommutative x y)
	in lteUnsumLeftSummandRight

ltePlus : (a, b : Nat) -> b `LTE` (a `plus` b)
ltePlus a Z = LTEZero
ltePlus a (S predb) = rewrite sym $ plusSuccRightSucc a predb in LTESucc $ ltePlus a predb

lteImplSuccMinusPreserved : (a, b : Nat)
	-> b `LTE` a
	-> (S a) `minus` b = S (a `minus` b)
lteImplSuccMinusPreserved a Z _ = cong $ sym $ minusZeroRight a
lteImplSuccMinusPreserved Z (S predb) lteBA = void $ succNotLTEzero lteBA
lteImplSuccMinusPreserved (S preda) (S predb) lteBA
	= lteImplSuccMinusPreserved preda predb $ fromLteSucc lteBA

natPlusInvertibleR : (a, b : Nat) -> (a `plus` b) `minus` b = a
natPlusInvertibleR a Z = trans (cong $ plusZeroRightNeutral a) $ minusZeroRight a
natPlusInvertibleR Z b = sym $ minusZeroN b
natPlusInvertibleR (S preda) (S predb)
	= trans (cong {f=\t => t `minus` predb} $ sym $ plusSuccRightSucc preda predb)
	$ trans (lteImplSuccMinusPreserved (plus preda predb) predb
		$ ltePlus preda predb)
	$ cong {f=S} $ natPlusInvertibleR preda predb

natPlusInvertibleL : (a, b : Nat) -> (b `plus` a) `minus` b = a
natPlusInvertibleL a b = rewrite plusCommutative b a in natPlusInvertibleR a b

lteToSumExpr :
	(x, m : Nat)
	-> m `LTE` x
	-> (k : Nat ** x = m `plus` k)
lteToSumExpr x Z lteMX = (x ** Refl)
lteToSumExpr Z (S predm) lteMX = void $ succNotLTEzero lteMX
lteToSumExpr (S predx) (S predm) lteMX
	= either
		(\ltMX =>
			let ltPMPX = fromLteSucc ltMX
			in let oldpr = lteToSumExpr predx (S predm) ltPMPX
			in (S $ getWitness oldpr
				** cong {f=S} $ trans (getProof oldpr)
				$ plusSuccRightSucc _ _))
		(\eqMX => (Z ** sym $ trans (cong $ plusZeroRightNeutral predm) eqMX))
	$ lteToLTERel lteMX


module Sub04Apply54x48

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

-- 3(18x+16) --A[6,-4]->B[1,-2]--> 3(4x+3)
ab54x30To12x9 :
  (l:Nat) -> P (S (S (S (S (plus (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                                  (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                            (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l)))))))))))) 2
    -> P (S (S (S (plus (plus l l) (plus l l))))) 2
ab54x30To12x9 l prf =
  let prf2 = lvDown (S (S (S (S (plus (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                                  (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                            (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l)))))))))))) 2
                    prf in
    let prf3 = ab54x30To12x9' l prf2 in lvDown (S (S (S (plus (plus l l) (plus l l))))) 3 prf3

export
apply54x48 : P (S (S (S (S (plus (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                                  (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                            (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l)))))))))))) 2
  -> (m : Nat **
        (LTE (S m)
             (S (S (S (S (plus (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l)))) (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                               (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l)))))))))))),
         P m 2))
apply54x48 {l} col = let col2 = ab54x30To12x9 l col in ((S (S (S (plus (plus l l) (plus l l))))) ** (lte54x48 l, col2)) where
  lte54x48 : (l:Nat) -> LTE (S (S (S (S (plus (plus l l) (plus l l))))))
                            (S (S (S (S (plus (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l)))) (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                                              (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))))))
  lte54x48 Z = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte54x48 (S k) = let lemma = lte54x48 k in
    rewrite (sym (plusSuccRightSucc k k)) in
    rewrite (sym (plusSuccRightSucc (plus k k) (S (plus k k)))) in
    rewrite (sym (plusSuccRightSucc (plus k k) (plus k k))) in
    rewrite (sym (plusSuccRightSucc (plus k k) k)) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) k) (S (S (S (S (plus (plus k k) k))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) k) (S (S (S (plus (plus k k) k)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) k) (S (S (plus (plus k k) k))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc) lemma


module BankersQueue

import Queue
import OStream

%default total
%access private

export
data BankersQueue a = BQ Int (OStream a) Int (OStream a)

check : Int -> OStream a -> Int -> OStream a -> BankersQueue a
check lenf f lenr r =
  if lenr <= lenf then BQ lenf f lenr r
  else BQ (lenf+lenr) (OStream.append f (OStream.reverse r)) 0 []

export
Queue BankersQueue where
  empty = BQ 0 [] 0 []
  isEmpty (BQ lenf f lenr r) = lenf == 0

  snoc (BQ lenf f lenr r) x = check lenf f (lenr + 1) (x :: r)

  head (BQ lenf []        lenr r) = idris_crash "empty queue"
  head (BQ lenf (x :: f') lenr r) = x

  tail (BQ lenf []        lenr r) = idris_crash "empty queue"
  tail (BQ lenf (x :: f') lenr r) = check (lenf - 1) f' lenr r


module Data.Fufunctor

import Data.Morphisms

%default total
%access public export
%language LinearTypes

-- FuFunctor is dual to Zifunctor
-- More precisely dual would be t c b a, but in current form
-- it is already used in ZIO library and (Schedule)
-- also it match the Function2 shape a -> b -> c

-- Since it is not exact dual the name is not CoZifunctor but Function2 Functor
-- or FuFunctor in short
interface Fufunctor (t : Type -> Type -> Type -> Type) where
  fumap : (rr -> r) -> (ee -> e) -> (a -> aa) -> t r e a -> t rr ee aa

  dimap : (rr -> r) -> (a -> aa) -> t r e a -> t rr e aa
  dimap r = fumap r id

  dimapRight : (ee -> e) -> (a -> aa) -> t r e a -> t r ee aa
  dimapRight e a = fumap id e a

  map : (a -> aa) -> t r e a -> t r e aa
  map = fumap id id

  contramap : (rr -> r) -> t r e a -> t rr e a
  contramap r = fumap r id id

-- Fufunctor Trimorphism where
--   fumap f g h (Trimo fa) = Trimo ( \ee -> \aa -> h (fa (f ee) (g aa)) )


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

||| Qualitative evaluations for
module GRL.Eval.Qualitative

import GRL.Common
import GRL.Model

%access public export

implementation [andSN] Cast SValue Nat where
  cast DENIED    = cast 0
  cast CONFLICT  = cast 1
  cast UNDECIDED = cast 1
  cast WEAKDEN   = cast 2
  cast NONE      = cast 3
  cast WEAKSATIS = cast 4
  cast SATISFIED = cast 5

implementation [andNS] Cast Nat SValue where
  cast Z                     = DENIED
  cast (S Z)                 = UNDECIDED
  cast (S (S Z))             = WEAKDEN
  cast (S (S (S Z)))         = NONE
  cast (S (S (S (S Z))))     = WEAKSATIS
  cast (S (S (S (S (S Z))))) = SATISFIED
  cast _                     = UNDECIDED

||| Calculate AND decomposition
getDecompAnd : List SValue -> SValue
getDecompAnd ss = cast @{andNS} $ foldl (\olds,s => min (toNat s) olds) (cast 5) ss
  where
    toNat : SValue -> Nat
    toNat sv = cast @{andSN} sv

implementation [orSN] Cast SValue Nat where
  cast DENIED    = cast 0
  cast WEAKDEN   = cast 1
  cast NONE      = cast 2
  cast WEAKSATIS = cast 3
  cast CONFLICT  = cast 4
  cast UNDECIDED = cast 4
  cast SATISFIED = cast 5

implementation [orNS] Cast Nat SValue where
  cast Z                     = DENIED
  cast (S Z)                 = WEAKDEN
  cast (S (S Z))             = NONE
  cast (S (S (S Z)))         = WEAKSATIS
  cast (S (S (S (S Z))))     = UNDECIDED
  cast (S (S (S (S (S Z))))) = SATISFIED
  cast _                     = UNDECIDED

||| Calculate IOR decomposition.
getDecompIOR : List SValue -> SValue
getDecompIOR ss = cast @{orNS} $ foldl (\olds,s => max (toNat s) olds) (cast 0) ss
  where
    toNat : SValue -> Nat
    toNat sv = cast @{orSN} sv

||| Calculate XOR decomposition.
getDecompXOR : List SValue -> SValue
getDecompXOR ss = cast @{orNS} $ foldl (\olds,s => min (toNat s) olds) (cast 5) ss
  where
    toNat : SValue -> Nat
    toNat sv = cast @{orSN} sv

||| Record to keep track of contribution valeu counts.
record ContribCount where
  constructor MkCCount
  noSatis  : Nat
  noWeakS  : Nat
  noWeakD  : Nat
  noDenied : Nat
  noUndec  : Nat

||| Default constructor for `ContribCount`
defCCount : ContribCount
defCCount = MkCCount Z Z Z Z Z

||| Implementation of `AdjustContributionCounters`
adJustCount : SValue -> ContribCount -> ContribCount
adJustCount SATISFIED cnt = record {noSatis  = (S (noSatis cnt))} cnt
adJustCount DENIED    cnt = record {noDenied = (S (noDenied cnt))} cnt
adJustCount WEAKSATIS cnt = record {noWeakS  = (S (noWeakS cnt))} cnt
adJustCount WEAKDEN   cnt = record {noWeakD  = (S (noWeakD cnt))} cnt
adJustCount UNDECIDED cnt = record {noUndec  = (S (noUndec cnt))} cnt
adJustCount _         cnt = cnt

||| Implementation of `AdjustContributionCounters` for a list of values.
adjustCounts : List SValue -> ContribCount
adjustCounts es = foldl (flip $ adJustCount) defCCount es

||| Implementation of the `WeightedContribution` look up table.
weightedContrib : SValue -> CValue -> SValue
weightedContrib x y = foldl (\res,(x',y',r') => if x == x' && y == y' then r' else res) NONE table
  where
    table : List (SValue, CValue, SValue)
    table = [ (DENIED   , MAKES  ,  DENIED   )
            , (DENIED   , HELPS  ,  WEAKDEN  )
            , (DENIED   , SOMEPOS,  WEAKDEN  )
            , (DENIED   , UNKNOWN,  NONE     )
            , (DENIED   , SOMENEG,  WEAKSATIS)
            , (DENIED   , HURTS  ,  WEAKSATIS)
            , (DENIED   , BREAK  ,  SATISFIED)
            , (WEAKDEN  , MAKES  ,  WEAKDEN  )
            , (WEAKDEN  , HELPS  ,  WEAKDEN  )
            , (WEAKDEN  , SOMEPOS,  WEAKDEN  )
            , (WEAKDEN  , UNKNOWN,  NONE     )
            , (WEAKDEN  , SOMENEG,  WEAKSATIS)
            , (WEAKDEN  , HURTS  ,  WEAKSATIS)
            , (WEAKDEN  , BREAK  ,  WEAKSATIS)
            , (WEAKSATIS, MAKES  ,  WEAKSATIS)
            , (WEAKSATIS, HELPS  ,  WEAKSATIS)
            , (WEAKSATIS, SOMEPOS,  WEAKSATIS)
            , (WEAKSATIS, UNKNOWN,  NONE     )
            , (WEAKSATIS, SOMENEG,  WEAKDEN  )
            , (WEAKSATIS, HURTS  ,  WEAKDEN  )
            , (WEAKSATIS, BREAK  ,  WEAKDEN  )
            , (SATISFIED, MAKES  ,  SATISFIED)
            , (SATISFIED, HELPS  ,  WEAKSATIS)
            , (SATISFIED, SOMEPOS,  WEAKSATIS)
            , (SATISFIED, UNKNOWN,  NONE     )
            , (SATISFIED, SOMENEG,  WEAKDEN  )
            , (SATISFIED, HURTS  ,  WEAKDEN  )
            , (SATISFIED, BREAK  ,  DENIED   )
            , (CONFLICT , MAKES  ,  UNDECIDED)
            , (CONFLICT , HELPS  ,  UNDECIDED)
            , (CONFLICT , SOMEPOS,  UNDECIDED)
            , (CONFLICT , UNKNOWN,  UNDECIDED)
            , (CONFLICT , SOMENEG,  UNDECIDED)
            , (CONFLICT , HURTS  ,  UNDECIDED)
            , (CONFLICT , BREAK  ,  UNDECIDED)
            , (UNDECIDED, MAKES  ,  UNDECIDED)
            , (UNDECIDED, HELPS  ,  UNDECIDED)
            , (UNDECIDED, SOMEPOS,  UNDECIDED)
            , (UNDECIDED, UNKNOWN,  UNDECIDED)
            , (UNDECIDED, SOMENEG,  UNDECIDED)
            , (UNDECIDED, HURTS  ,  UNDECIDED)
            , (UNDECIDED, BREAK  ,  UNDECIDED)
            , (NONE     , MAKES  ,  NONE     )
            , (NONE     , HELPS  ,  NONE     )
            , (NONE     , SOMEPOS,  NONE     )
            , (NONE     , UNKNOWN,  NONE     )
            , (NONE     , SOMENEG,  NONE     )
            , (NONE     , HURTS  ,  NONE     )
            , (NONE     , BREAK  ,  NONE     )]

||| Implementation of the `CompareSatisfiedAndDenied`  resolution
cmpSatAndDen : ContribCount -> SValue
cmpSatAndDen cnt =
  if noSatis cnt > 0 && noDenied cnt > 0
    then CONFLICT
    else if noSatis cnt > 0 && noDenied cnt == 0
      then SATISFIED
      else if noDenied cnt > 0 && noSatis cnt == 0
        then DENIED
        else if noSatis cnt == 0 && noDenied cnt == 0
          then NONE
          else NONE

||| Implementation of the `CompareWSandWD` function
cmpWSandWD : ContribCount -> SValue
cmpWSandWD cnt =
  if noWeakS cnt > noWeakD cnt
    then WEAKSATIS
    else if noWeakD cnt > noWeakS cnt
      then WEAKDEN
      else if noWeakD cnt == noWeakS cnt
        then NONE
        else NONE

||| Implementation of the `CombineContributionutions` function
combineContribs : ContribCount -> SValue
combineContribs c = doCombine (cmpWSandWD c) (cmpSatAndDen c)
  where
    table : List (SValue, SValue, SValue)
    table =[ (WEAKDEN  , DENIED   , DENIED   )
           , (WEAKDEN  , SATISFIED, WEAKSATIS)
           , (WEAKDEN  , CONFLICT , CONFLICT )
           , (WEAKDEN  , NONE     , WEAKDEN  )
           , (WEAKSATIS, DENIED   , WEAKDEN  )
           , (WEAKSATIS, SATISFIED, SATISFIED)
           , (WEAKSATIS, CONFLICT , CONFLICT )
           , (WEAKSATIS, NONE     , WEAKSATIS)
           , (NONE     , DENIED   , DENIED   )
           , (NONE     , SATISFIED, SATISFIED)
           , (NONE     , CONFLICT , CONFLICT )
           , (NONE     , NONE     , NONE     )]

    doCombine : SValue -> SValue -> SValue
    doCombine x y = foldl (\res,(x',y',r') => if x == x' && y == y' then r' else res) NONE table

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


-- Import the Cairo prelude
import Cairo
import Data.List

-- Define a datatype
record Account where
  constructor MkAccount
  number: Felt
  balance: Felt

-- Read from private input (using inline Cairo)
%foreign
  """
  code:
  func Main_readFromInput(key) -> (result):
      tempvar result
      %{
          from starkware.cairo.common.math_utils import as_int
          val = program_input[ids.key]
          ids.result = as_int(val, PRIME) % PRIME
      %}
      return (result)
  end
  """
readFromInput : Felt -> Felt

-- Creates an account based on an index into the JSON array in `input.json`
createAccount : Felt -> Account
createAccount index = MkAccount number balance
  where number : Felt
        number = readFromInput index
        balance : Felt
        balance = readFromInput (index + 1)

-- List of available accounts (we assume there are 3 accounts)
privateAccounts : List Account
privateAccounts = map createAccount [0,2,4]

-- Define a function which gets a list of accounts and returns the sum of their balances
sumOfBalances : List Account -> Felt
sumOfBalances accounts = sum (map balance accounts)

-- Computes the hash of the account data (no need to pass the pedersen_ptr)
hashOfAccountData : List Account -> Felt
hashOfAccountData accounts = foldl pedersenHash 3 (foldMap (\a => [a.number, a.balance]) accounts)

-- The main entry point:
-- Computes and outputs the hash of the account data
-- together with the sum of the balances
main : Cairo ()
main = do
  output $ hashOfAccountData privateAccounts
  output $ sumOfBalances privateAccounts


module Flexidisc.Dec.IsYes

%default total

||| Build at type level the proof that a decidable property is valid
public export
data IsYes : prop -> Type where
  SoTrue : IsYes (Yes prop)

%name IsYes yes, prf, ok

||| Demote a proof from the type level to the value level
export
getProof : {witness : Dec prop} -> IsYes witness -> prop
getProof yes {witness = (Yes prf)} = prf
getProof yes {witness = (No contra)} impossible

||| If I can prove two times that a property doesn't hold,
||| the two proofs are equal
export
uniqueYes : (prop : Dec any) -> (x, y : IsYes prop) -> x = y
uniqueYes (Yes prf) SoTrue SoTrue = Refl
uniqueYes (No _) SoTrue _ impossible


module Ch03.Exercise_3_5_17

import Ch03.Arith

%default total

--------------------------------------------------------------------------------
-- Exercise 3.5.17
--------------------------------------------------------------------------------

||| Big step evaluation rules expressed in terms of reflexive-transitive closure
||| of small-step evaluation rules
data BInE : Term -> Term -> Type where
  BInEValue : {pf : IsValue v} -> BInE v v
  BInEIfTrue : {pf : IsValue v2} ->
               {t1, t2, t3 : Term} ->
               EvalsToStar t1 True ->
               EvalsToStar t2 v2 ->
               BInE (IfThenElse t1 t2 t3) v2
  BInEIfFalse : {pf : IsValue v3} ->
                {t1, t2, t3 : Term} ->
                EvalsToStar t1 False ->
                EvalsToStar t3 v3 ->
                BInE (IfThenElse t1 t2 t3) v3
  BInESucc : {pf : IsNumValue nv1} ->
             {t1 : Term} ->
             EvalsToStar t1 nv1 ->
             BInE (Succ t1) (Succ nv1)
  BInEPredZero : {t1 : Term} ->
                 EvalsToStar t1 Zero ->
                 BInE (Pred t1) Zero
  BInEPredSucc : {t1 : Term} ->
                 {pf : IsNumValue nv1} ->
                 EvalsToStar t1 (Succ nv1) ->
                 BInE (Pred t1) nv1
  BInEIsZeroZero : {t1 : Term} ->
                   EvalsToStar t1 Zero ->
                   BInE (IsZero t1) True
  BInEIsZeroSucc : {t1 : Term} ->
                   {pf : IsNumValue nv1} ->
                   EvalsToStar t1 (Succ nv1) ->
                   BInE (IsZero t1) False

||| Given a (one-step) derivation in the `BInE`-calculus, computes its corresponding derivation
||| in the `E`-calculus.
from_BInE_to_E : BInE t v -> EvalsToStar t v
from_BInE_to_E BInEValue = Refl
from_BInE_to_E (BInEIfTrue {t2} {t3} x y) = map {func=(\t => IfThenElse t t2 t3)} EIf x
                                            ++ Cons EIfTrue y
from_BInE_to_E (BInEIfFalse {t2} {t3} x y) = map {func=(\t => IfThenElse t t2 t3)} EIf x
                                            ++ Cons EIfFalse y
from_BInE_to_E (BInESucc x) = map ESucc x
from_BInE_to_E (BInEPredZero x) = map EPred x ++ weaken EPredZero
from_BInE_to_E (BInEPredSucc {pf} x) = map EPred x ++ weaken (EPredSucc {pf=pf})
from_BInE_to_E (BInEIsZeroZero x) = map EIsZero x ++ weaken EIsZeroZero
from_BInE_to_E (BInEIsZeroSucc {pf} x) = map EIsZero x ++ weaken (EIsZeroSucc {pf=pf})

--------------------------------------------------------------------------------
-- Sublemmas of `from_E_to_BInE`
--------------------------------------------------------------------------------

lemma_EIfTrue : {t2, t3 : Term} ->
                {pf : IsValue v} ->
                (d' : EvalsToStar t2 v) ->
                (r : BInE (IfThenElse True t2 t3) v ** Cons EIfTrue d' = from_BInE_to_E r)
lemma_EIfTrue {pf} d' = (BInEIfTrue {pf=pf} Refl d' ** Refl)

lemma_EIfFalse : {t2, t3 : Term} ->
                 {pf : IsValue v} ->
                 (d' : EvalsToStar t3 v) ->
                 (r : BInE (IfThenElse False t2 t3) v ** Cons EIfFalse d' = from_BInE_to_E r)
lemma_EIfFalse {pf} d' = (BInEIfFalse {pf=pf} Refl d' ** Refl)

lemma_EIf : {t1, t2, t3 : Term} ->
            {pf : IsValue v} ->
            {x : EvalsTo t1 t1'} ->
            (d' : EvalsToStar (IfThenElse t1' t2 t3) v) ->
            (r' : BInE (IfThenElse t1' t2 t3) v ** d' = from_BInE_to_E r') ->
            (r : BInE (IfThenElse t1 t2 t3) v ** Cons (EIf x) d' = from_BInE_to_E r)
lemma_EIf {pf} {x} d' (r' ** pf') = case r' of
                                         BInEValue {pf} => absurd (ifThenElseNotNormal pf)
                                         BInEIfTrue d1 d2 => (BInEIfTrue {pf=pf} (Cons x d1) d2 ** cong pf')
                                         BInEIfFalse d1 d2 => (BInEIfFalse {pf=pf} (Cons x d1) d2 ** cong pf')

lemma_ESucc : {t1 : Term} ->
              {pf : IsValue v} ->
              (x : EvalsTo t1 t1') ->
              (r' : BInE (Succ t1') v ** d' = from_BInE_to_E r') ->
              (r : BInE (Succ t1) v ** Cons (ESucc x) d' = from_BInE_to_E r)
lemma_ESucc {pf} x (r' ** pf') = case r' of
                                      BInEValue => case succIsValueIf pf of
                                                        nv_pf@(ConvertedFrom nv) => (BInESucc {pf=nv_pf} (weaken x) ** cong pf')
                                      BInESucc {pf} d'' => (BInESucc {pf=pf} (Cons x d'') ** cong pf')

lemma_EPred : {t1, t1' : Term} ->
              {pf : IsValue v} ->
              (x : EvalsTo t1 t1') ->
              (r' : BInE (Pred t1') v ** d' = from_BInE_to_E r') ->
              (r : BInE (Pred t1) v ** Cons (EPred x) d' = from_BInE_to_E r)
lemma_EPred {pf} x (r' ** pf') = case r' of
                                      BInEValue {pf=pf_val} => absurd (predNotValue pf_val)
                                      BInEPredZero y => (BInEPredZero (Cons x y) ** cong pf')
                                      BInEPredSucc {pf=pf_v} y => (BInEPredSucc {pf=pf_v} (Cons x y) ** cong pf')

lemma_EIsZero : {t1, t1', v : Term} ->
                {pf : IsValue v} ->
                (x : EvalsTo t1 t1') ->
                (r' : BInE (IsZero t1') v ** d' = from_BInE_to_E r') ->
                (r : BInE (IsZero t1) v ** Cons (EIsZero x) d' = from_BInE_to_E r)
lemma_EIsZero {pf} x (r' ** pf') = case r' of
                                        BInEValue {pf=pf_val} => absurd (isZeroNotValue pf_val)
                                        BInEIsZeroZero y => (BInEIsZeroZero (Cons x y) ** cong pf')
                                        BInEIsZeroSucc {pf=pf_v} y => (BInEIsZeroSucc {pf=pf_v} (Cons x y) ** cong pf')

||| Deconstructs a derivation of a term `t` to a value `v` in the `E`-calculus into a (one-step) derivation
||| in the `BInE`-calculus.
from_E_to_BInE : {pf : IsValue v} ->
                 (d : EvalsToStar t v) -> (r : BInE t v ** d = from_BInE_to_E r)
from_E_to_BInE {pf} {t = True} Refl = (BInEValue {pf=ConvertedFrom (Left True)} {v=True} ** Refl)
from_E_to_BInE {pf} {t = True} (Cons x y) = absurd (valuesDontEvaluate {pf=ConvertedFrom (Left True)} x)
from_E_to_BInE {pf} {t = False} Refl = (BInEValue {pf=ConvertedFrom (Left False)} {v=False} ** Refl)
from_E_to_BInE {pf} {t = False} (Cons x y) = absurd (valuesDontEvaluate {pf=ConvertedFrom (Left False)} x)
from_E_to_BInE {pf} {t = (IfThenElse x y z)} Refl = absurd (ifThenElseNotNormal pf)
from_E_to_BInE {pf} {t = (IfThenElse x y z)} (Cons w s) = case w of
                                                               EIfTrue => lemma_EIfTrue {pf=pf} s
                                                               EIfFalse => lemma_EIfFalse {pf=pf} s
                                                               (EIf r) => lemma_EIf {pf=pf} s (from_E_to_BInE {pf=pf} s)
from_E_to_BInE {pf} {t = Zero} d = case valuesAreNormal' {pf=ConvertedFrom (Right Zero)} d of
                                        Refl => case d of
                                                     Refl => (BInEValue {pf=ConvertedFrom (Right Zero)} ** Refl)
                                                     (Cons x y) => absurd (valuesDontEvaluate {pf=ConvertedFrom (Right Zero)} x)
from_E_to_BInE {pf} {t = (Succ x)} Refl = case succIsValueIf pf of
                                               ConvertedFrom nv => (BInEValue {pf=ConvertedFrom (Right (Succ nv))} ** Refl)
from_E_to_BInE {pf} {t = (Succ x)} (Cons y z) = case y of
                                                     ESucc y' => lemma_ESucc {pf=pf} y' (from_E_to_BInE {pf=pf} z)
from_E_to_BInE {pf} {t = (Pred x)} Refl = absurd (predNotValue pf)
from_E_to_BInE {pf} {t = (Pred x)} (Cons y z) = case y of
                                                     EPredZero => case valuesAreNormal {pf=ConvertedFrom (Right Zero)} z of
                                                                       Refl => (BInEPredZero Refl ** Refl)
                                                     EPredSucc {nv1} {pf=pf_nv} => case valuesAreNormal {pf=numValueIsValue pf_nv} z of
                                                                                Refl => (BInEPredSucc {pf=pf_nv} Refl ** Refl)
                                                     EPred y' => lemma_EPred {pf=pf} y' (from_E_to_BInE {pf=pf} z)
from_E_to_BInE {pf} {t = (IsZero x)} Refl = absurd (isZeroNotValue pf)
from_E_to_BInE {pf} {t = (IsZero x)} (Cons y z) = case y of
                                                       EIsZeroZero => case valuesAreNormal {pf=ConvertedFrom (Left True)} z of
                                                                           Refl => (BInEIsZeroZero Refl ** Refl)
                                                       EIsZeroSucc => case valuesAreNormal {pf=ConvertedFrom (Left False)} z of
                                                                           Refl => (BInEIsZeroSucc Refl ** Refl)
                                                       EIsZero y' => lemma_EIsZero {pf=pf} y' (from_E_to_BInE {pf=pf} z)

||| Converts a derivation in `BInE`-calculus to a derivation in the `B`-calculus.
from_BInE_to_B : {pf : IsValue v} -> BInE t v -> BigEvalsTo t v
from_BInE_to_B {pf} BInEValue = BValue {pf=pf}
from_BInE_to_B {pf} (BInEIfTrue y z) = let pf_true = ConvertedFrom (Left True)
                                           y' = fst (from_E_to_BInE {pf=pf_true} y)
                                           z' = fst (from_E_to_BInE {pf=pf} z) in
                                           BIfTrue {pf=pf} (from_BInE_to_B {pf=pf_true} y') (from_BInE_to_B {pf=pf} z')
from_BInE_to_B {pf} (BInEIfFalse y z) = let pf_false = ConvertedFrom (Left False)
                                            y' = fst (from_E_to_BInE {pf=pf_false} y)
                                            z' = fst (from_E_to_BInE {pf=pf} z) in
                                            BIfFalse {pf=pf} (from_BInE_to_B {pf=pf_false} y') (from_BInE_to_B {pf=pf} z')
from_BInE_to_B {pf} (BInESucc {pf=pf_nv} y) = let y' = fst (from_E_to_BInE {pf=numValueIsValue pf_nv} y) in
                                                  BSucc {pf=pf_nv} (from_BInE_to_B {pf=numValueIsValue pf_nv} y')
from_BInE_to_B {pf} (BInEPredZero x) = let pf_zero = ConvertedFrom (Right Zero)
                                           x' = fst (from_E_to_BInE {pf=pf_zero} x) in
                                           BPredZero (from_BInE_to_B {pf=pf_zero} x')
from_BInE_to_B {pf} (BInEPredSucc {pf=pf_v} y) = let pf_succ = numValueIsValue (succNumValueIsNumValue pf_v)
                                                     y' = fst (from_E_to_BInE {pf=pf_succ} y) in
                                                     BPredSucc {pf=pf_v} (from_BInE_to_B {pf=pf_succ} y')
from_BInE_to_B {pf} (BInEIsZeroZero x) = let pf_zero = ConvertedFrom (Right Zero)
                                             x' = fst (from_E_to_BInE {pf=pf_zero} x) in
                                             BIsZeroZero (from_BInE_to_B {pf=pf_zero} x')
from_BInE_to_B {pf} (BInEIsZeroSucc {pf=pf_v} y) = let pf_succ = numValueIsValue (succNumValueIsNumValue pf_v)
                                                       y' = fst (from_E_to_BInE {pf=pf_succ} y) in
                                                       BIsZeroSucc {pf=pf_v} (from_BInE_to_B {pf=pf_succ} y')

||| Proof that if a term `t` evaluates to a value `v` under the reflexive transitive
||| closure of the small-step evaluation rules, then it also evaluates to it under the
||| big-step evaluation rules.
starImpliesBig : {pf : IsValue v} -> EvalsToStar t v -> BigEvalsTo t v
starImpliesBig {pf} d = from_BInE_to_B {pf=pf} (fst (from_E_to_BInE {pf=pf} d))

||| Proof that if a term `t` evaluates to a value `v` under the big-step evaluation rules,
||| then it also evaluates to it under the reflexive transitive closure of the small-step
||| rules.
bigImpliesStar : {pf : IsValue v} -> BigEvalsTo t v -> EvalsToStar t v
bigImpliesStar {pf} BValue = Refl
bigImpliesStar {pf} (BIfTrue y z) = let y' = bigImpliesStar {pf=ConvertedFrom (Left True)} y
                                        z' = bigImpliesStar {pf=pf} z in
                                        from_BInE_to_E (BInEIfTrue {pf=pf} y' z')
bigImpliesStar {pf} (BIfFalse y z) = let y' = bigImpliesStar {pf=ConvertedFrom (Left False)} y
                                         z' = bigImpliesStar {pf=pf} z in
                                         from_BInE_to_E (BInEIfFalse {pf=pf} y' z')
bigImpliesStar {pf} (BSucc {pf=pf_nv} y) = let y' = bigImpliesStar {pf=numValueIsValue pf_nv} y in
                                               from_BInE_to_E (BInESucc {pf=pf_nv} y')
bigImpliesStar {pf} (BPredZero x) = let x' = bigImpliesStar {pf=pf} x in
                                        from_BInE_to_E (BInEPredZero x')
bigImpliesStar {pf} (BPredSucc {pf=pf_nv} y) = let y' = bigImpliesStar {pf=numValueIsValue (succNumValueIsNumValue pf_nv)} y in
                                                   from_BInE_to_E (BInEPredSucc {pf=pf_nv} y')
bigImpliesStar {pf} (BIsZeroZero x) = let x' = bigImpliesStar {pf=ConvertedFrom (Right Zero)} x in
                                          from_BInE_to_E (BInEIsZeroZero x')
bigImpliesStar {pf} (BIsZeroSucc {pf=pf_nv} y) = let y' = bigImpliesStar {pf=numValueIsValue (succNumValueIsNumValue pf_nv)} y in
                                                     from_BInE_to_E (BInEIsZeroSucc {pf=pf_nv} y')


import Ifui.Html
import Data.Vect
import Data.List

data Action : Nat -> Type where
  SetInput : String -> Action n
  AddTodo : Action n

State : Type
State = (String, (n:Nat ** Vect n String))

ActionTy : State -> Type
ActionTy = \(_, (n ** _)) => Action n

setInput : (s : State) -> String -> ActionTy s
setInput (_, (n ** _)) x = SetInput x

addTodo : (s : State) -> ActionTy s
addTodo (_, (n ** _)) = AddTodo

view : (s : State) -> Html (ActionTy s)
view x = textSpan "ola"

update : (s : State) -> ActionTy s -> State
update (y, (n ** v)) (SetInput s) = (s, (n ** v))
update (y, (n ** v)) AddTodo = ("", (S n ** y :: v))

main : IO ()
main =
  startHtmlView ("", (0 ** [])) update view


> module Vect.Properties

> import Data.Vect
> import Data.Vect.Quantifiers
> import Data.Fin

> import Vect.Operations
> import Sigma.Sigma
> import Sigma.Operations
> import Pairs.Operations
> import Exists.Operations
> import Decidable.Predicates
> import Rel.TotalPreorder
> import Rel.TotalPreorderOperations
> import Nat.LTProperties
> import Fin.Properties
> import Fun.Operations

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

> {-
> implementation Uninhabited (Elem {a} x Nil) where
>   uninhabited Here impossible
>   uninhabited (There p) impossible
> -}

Injectivity (of |flip index|):

> ||| Injectivity (one direction)
> Injective1 : Vect n t -> Type
> Injective1 {n} xs = (i : Fin n) -> (j : Fin n) -> index i xs = index j xs -> i = j

> ||| Injectivity (the other direction)
> Injective2 : Vect n t -> Type
> Injective2 {n} xs = (i : Fin n) -> (j : Fin n) -> Not (i = j) -> Not (index i xs = index j xs)

> ||| Injective1 implies Injective2
> injectiveLemma : (xs : Vect n t) -> Injective1 xs -> Injective2 xs
> injectiveLemma xs i1xs i j contra = contra . (i1xs i j)
> %freeze injectiveLemma

> ||| Tail preserves injectivity (one direction)
> injectiveTailLemma1 : (xs : Vect (S n) t) -> Injective1 xs -> Injective1 (tail xs)
> injectiveTailLemma1  Nil      p _ _ _ impossible
> injectiveTailLemma1 (x :: xs) p i j q = FSInjective i j (p (FS i) (FS j) q') where
>   q' : index (FS i) (x :: xs) = index (FS j) (x :: xs)
>   q' = q
> %freeze injectiveTailLemma1

> ||| Tail preserves injectivity (the other direction)
> injectiveTailLemma2 : (xs : Vect (S n) t) -> Injective2 xs -> Injective2 (tail xs)
> injectiveTailLemma2  Nil      p _ _ _ impossible
> injectiveTailLemma2 (x :: xs) p i j q = p (FS i) (FS j) (fsInjective2 i j q)
> %freeze injectiveTailLemma2

Indexing and lookup

> |||
> indexLemma : (k : Fin n) -> (xs : Vect n t) -> Elem (index k xs) xs
> indexLemma {n = Z}       k   Nil      = absurd k
> indexLemma {n = S m}  FZ    (x :: xs) = Here
> indexLemma {n = S m} (FS k) (x :: xs) = There (indexLemma k xs)
> %freeze indexLemma

> |||
> indexLookupLemma : (x : alpha) ->
>                    (xs : Vect n alpha) ->
>                    (prf : Elem x xs) ->
>                    index (lookup x xs prf) xs = x
> indexLookupLemma x  Nil        prf        = absurd prf
> indexLookupLemma x (x :: xs)   Here       = Refl
> indexLookupLemma x (x' :: xs) (There prf) =
>   let ih = indexLookupLemma x xs prf in rewrite ih in Refl
> {-
> indexLookupLemma x (x' :: xs) (There prf) = trans s1 (trans s2 s3) where
>   s1 : index (lookup x (x' :: xs) (There prf)) (x' :: xs)
>        =
>        index (FS (lookup x xs prf)) (x' :: xs)
>   s1 = Refl
>   s2 : index (FS (lookup x xs prf)) (x' :: xs)
>        =
>        index (lookup x xs prf) xs
>   s2 = Refl
>   s3 : index (lookup x xs prf) xs
>        =
>        x
>   s3 = indexLookupLemma x xs prf
> -}
> %freeze indexLookupLemma

> |||
> lookupIndexLemma : (k : Fin n) ->
>                    (xs : Vect n t) ->
>                    (p : Injective2 xs) ->
>                    (q : Elem (index k xs) xs) ->
>                    lookup (index k xs) xs q = k
> lookupIndexLemma  FZ     Nil      _  _        impossible
> lookupIndexLemma  FZ    (x :: xs) p  Here     = Refl
> lookupIndexLemma  FZ    (x :: xs) p (There q) = s5 where
>   s1 : Not (FZ = lookup x (x :: xs) (There q))
>   s1 Refl impossible
>   s2 : index FZ (x :: xs) = x
>   s2 = Refl
>   s3 : index (lookup x (x :: xs) (There q)) (x :: xs) = x
>   s3 = indexLookupLemma x (x :: xs) (There q)
>   s4 : index FZ (x :: xs) = index (lookup x (x :: xs) (There q)) (x :: xs)
>   s4 = trans s2 (sym s3)
>   s5 : lookup (index FZ (x :: xs)) (x :: xs) (There q) = FZ
>   s5 = void ((p FZ (lookup x (x :: xs) (There q)) s1) s4)
> lookupIndexLemma (FS k)  Nil      _  _        impossible
> lookupIndexLemma (FS k) (_ :: xs) p  Here     = s5 where
>   s1 : Not (FZ = FS k)
>   s1 Refl impossible
>   s2 : index FZ ((index k xs) :: xs) = index (FS k) ((index k xs) :: xs)
>   s2 = Refl
>   s5 : lookup (index (FS k) ((index k xs) :: xs)) ((index k xs) :: xs) Here = (FS k)
>   s5 = void ((p FZ (FS k) s1) s2)
> lookupIndexLemma (FS k) (x :: xs) p (There q) =
>   let p' = injectiveTailLemma2 (x :: xs) p in
>   let ih = lookupIndexLemma k xs p' q in
>   rewrite ih in Refl
> %freeze lookupIndexLemma

> |||
> -- indexToVectLemma : {A : Type} -> (f : Fin n -> A) -> (k : Fin n) -> f k = index k (toVect f)

Membership, quantifiers:

> ||| Membership => non emptyness
> elemLemma : {A : Type} -> {n : Nat} ->
>             (a : A) -> (as : Vect n A) ->
>             Elem a as -> LT Z n
> elemLemma {n = Z}   a Nil p = absurd p
> elemLemma {n = S m} a as  p = ltZS m
> %freeze elemLemma

> |||
> AnySigmaLemma : {A : Type} -> {P : A -> Type} -> {as : Vect n A} ->
>                 Any P as -> Sigma A P
> AnySigmaLemma (Here px) = MkSigma _ px
> AnySigmaLemma (There prf) = AnySigmaLemma prf

> |||
> AnyExistsLemma : {A : Type} -> {P : A -> Type} -> {as : Vect n A} ->
>                  Any P as -> Exists P
> AnyExistsLemma (Here px) = Evidence _ px
> AnyExistsLemma (There prf) = AnyExistsLemma prf

> ElemAnyLemma : {A : Type} -> {P : A -> Type} -> P a -> Elem a as -> Any P as
> ElemAnyLemma p Here = Here p
> ElemAnyLemma p (There e) = There (ElemAnyLemma p e)
> %freeze ElemAnyLemma

> |||
> decAny : {A : Type} -> {P : A -> Type} -> Dec1 P -> Dec1 (Any P)
> decAny d1P = any d1P
> %freeze decAny

> elemNotHeadTail : Elem a (a' :: as) -> Not (a = a') -> Elem a as
> elemNotHeadTail  Here     q = void (q Refl)
> elemNotHeadTail (There p) _ = p

> decElemTailDecElemHeadTail : {A : Type} -> {n : Nat} -> (DecEq A) =>
>                              (a : A) -> (a' : A) -> (as : Vect n A)->
>                              Dec (Elem a as) -> Dec (Elem a (a' :: as))
> decElemTailDecElemHeadTail a a' as (Yes p) = Yes (There p)
> decElemTailDecElemHeadTail a a' as (No  p) with (decEq a a')
>   | Yes q = Yes (replace {P = \ X => Elem a (X :: as)} q Here)
>   |  No q =  No (\ prf => p (elemNotHeadTail prf q))

> |||
> decElem : {A : Type} -> {n : Nat} -> (DecEq A) =>
>           (a : A) -> (as : Vect n A)-> Dec (Elem a as)
> decElem a Nil = No absurd
> decElem a (a' :: as) with (decEq a a')
>   | Yes p  = Yes (replace {P = \ X => Elem a (X :: as)} p Here)
>   | No  p  = decElemTailDecElemHeadTail a a' as (decElem a as)

Container monad properties

> |||
> mapLemma : {A, B : Type} -> (as : Vect n A) -> (f : A -> B) ->
>            (a : A) -> Elem a as -> Elem (f a) (map f as)
> mapLemma  Nil      f a aeas = absurd aeas
> mapLemma (a :: as) f a   Here       = Here
> mapLemma (a :: as) f a' (There prf) = There (mapLemma as f a' prf)
> %freeze mapLemma

> |||
> mapIdfLemma : {A, B : Type} -> (as : Vect n A) -> (f : A -> B) ->
>               (ab : (A,B)) -> Elem ab (map (pair (Prelude.Basics.id,f)) as) ->
>               f (fst ab) = snd ab
> mapIdfLemma  Nil      f  ab     p        = absurd p
> mapIdfLemma (a :: as) f (a, _)  Here     = Refl
> mapIdfLemma (a :: as) f  ab    (There p) = mapIdfLemma as f ab p
> %freeze mapIdfLemma

Filtering

> ||| |filter| preserves membership
> filterLemma : {A : Type} ->
>               {P : A -> Type} ->
>               (d1P : Dec1 P) ->
>               (a : A) ->
>               (as : Vect n A) ->
>               Elem a as ->
>               (p : P a) ->
>               Elem a (getProof (filter d1P as))
> filterLemma d1P a   Nil       prf  p = absurd prf
> filterLemma d1P a1 (a1 :: as) Here p with (filter d1P as)
>   | (MkSigma n as') with (d1P a1)
>     | (Yes _) = Here {x = a1} {xs = as'}
>     | (No  contra) = void (contra p)
> filterLemma {A} {P} d1P a1 (a2 :: as) (There prf) p with (filter d1P as) proof itsEqual
>   | (MkSigma n as') with (d1P a2)
>     | (Yes _) = -- There {x = a1} {xs = as'} {y = a2} (filterLemma d1P a1 as prf p)
>                 There {x = a1} {xs = as'} {y = a2} $
>                   replace {P = \rec => Elem a1 (getProof rec)} (sym itsEqual) $
>                     filterLemma {A} {P} d1P a1 as prf p
>     | (No  _) = -- filterLemma {A} {P} d1P a1 as prf p
>                 replace {P = \rec => Elem a1 (getProof rec)} (sym itsEqual) $
>                   filterLemma {P = P} d1P a1 as prf p
> %freeze filterLemma

> ||| |filterTagSigma| preserves membership
> filterTagSigmaLemma : {A : Type} ->
>                       {P : A -> Type} ->
>                       {n : Nat} ->
>                       (d1P : Dec1 P) ->
>                       (a : A) ->
>                       (as : Vect n A) ->
>                       Elem a as ->
>                       (p : P a) ->
>                       Elem a (map Sigma.Operations.outl (Sigma.Operations.outr (filterTagSigma d1P as)))
> filterTagSigmaLemma d1P a   Nil       prf  p = absurd prf
> filterTagSigmaLemma d1P a1 (a1 :: as) Here p with (filterTagSigma d1P as)
>   | (MkSigma n aps') with (d1P a1)
>     | (Yes _) = Here {x = a1} {xs = map Sigma.Operations.outl aps'}
>     | (No  contra) = void (contra p)
> filterTagSigmaLemma d1P a1 (a2 :: as) (There prf) p with (filterTagSigma d1P as) proof itsEqual
>   | (MkSigma n aps') with (d1P a2)
>     | (Yes _) = -- There {x = a1} {xs = map Sigma.Operations.outl aps'} {y = a2} (filterTagSigmaLemma d1P a1 as prf p)
>                 There {x = a1} {xs = map Sigma.Operations.outl aps'} {y = a2} $
>                   replace {P = \rec => Elem a1 (map Sigma.Operations.outl (getProof rec))} (sym itsEqual) $
>                     filterTagSigmaLemma d1P a1 as prf p
>     | (No  _) = -- filterTagSigmaLemma d1P a1 as prf p
>                 replace {P = \rec => Elem a1 (map Sigma.Operations.outl (getProof rec))} (sym itsEqual) $
>                   filterTagSigmaLemma d1P a1 as prf p
> %freeze filterTagSigmaLemma

> ||| |filterTagExists| preserves membership
> filterTagExistsLemma : {A : Type} ->
>                        {P : A -> Type} ->
>                        {n : Nat} ->
>                        (d1P : Dec1 P) ->
>                        (a : A) ->
>                        (as : Vect n A) ->
>                        Elem a as ->
>                        (p : P a) ->
>                        Elem a (map Exists.getWitness (Sigma.getProof (filterTagExists d1P as)))
> filterTagExistsLemma d1P a   Nil       prf  p = absurd prf
> filterTagExistsLemma d1P a1 (a1 :: as) Here p with (filterTagExists d1P as)
>   | (MkSigma n aps') with (d1P a1)
>     | (Yes _) = Here {x = a1} {xs = map getWitness aps'}
>     | (No  contra) = void (contra p)
> filterTagExistsLemma d1P a1 (a2 :: as) (There prf) p with (filterTagExists d1P as) proof itsEqual
>   | (MkSigma n aps') with (d1P a2)
>     | (Yes _) = -- There {x = a1} {xs = map getWitness aps'} {y = a2} (filterTagExistsLemma d1P a1 as prf p)
>                 There {x = a1} {xs = map getWitness aps'} {y = a2} $
>                   replace {P = \rec => Elem a1 (map Exists.getWitness (getProof rec))} (sym itsEqual) $
>                     filterTagExistsLemma d1P a1 as prf p
>     | (No  _) = -- filterTagExistsLemma d1P a1 as prf p
>                 replace {P = \rec => Elem a1 (map Exists.getWitness (getProof rec))} (sym itsEqual) $
>                   filterTagExistsLemma d1P a1 as prf p
> %freeze filterTagExistsLemma

> ||| |filterTagSubset| preserves membership
> filterTagSubsetLemma : {A : Type} ->
>                        {P : A -> Type} ->
>                        {n : Nat} ->
>                        (d1P : Dec1 P) ->
>                        (a : A) ->
>                        (as : Vect n A) ->
>                        Elem a as ->
>                        (p : P a) ->
>                        Elem a (map Subset.getWitness (Sigma.getProof (filterTagSubset d1P as)))
> filterTagSubsetLemma d1P a   Nil       prf  p = absurd prf
> filterTagSubsetLemma d1P a1 (a1 :: as) Here p with (filterTagSubset d1P as)
>   | (MkSigma n aps') with (d1P a1)
>     | (Yes _) = Here {x = a1} {xs = map getWitness aps'}
>     | (No  contra) = void (contra p)
> filterTagSubsetLemma d1P a1 (a2 :: as) (There prf) p with (filterTagSubset d1P as) proof itsEqual
>   | (MkSigma n aps') with (d1P a2)
>     | (Yes _) = -- There {x = a1} {xs = map getWitness aps'} {y = a2} (filterTagLemma d1P a1 as prf p)
>                 There {x = a1} {xs = map getWitness aps'} {y = a2} $
>                   replace {P = \rec => Elem a1 (map Subset.getWitness (getProof rec))} (sym itsEqual) $
>                     filterTagSubsetLemma d1P a1 as prf p
>     | (No  _) = -- filterTagLemma d1P a1 as prf p
>                 replace {P = \rec => Elem a1 (map Subset.getWitness (getProof rec))} (sym itsEqual) $
>                   filterTagSubsetLemma d1P a1 as prf p
> %freeze filterTagSubsetLemma

> {- Just commented out for testing
> ||| |filter| preserves injectivity
> injectiveFilterLemma : {A : Type} ->
>                        {P : A -> Type} ->
>                        {n : Nat} ->
>                        (dP : Dec1 P) ->
>                        (as : Vect n A) ->
>                        Injective1 as ->
>                        Injective1 (getProof (filter dP as))
> -}
> {-
>     = s0 where
>   n'  : Nat
>   n'  = getWitness (filter dP (a :: as))
>   as' : Vect n' A
>   as' = getProof (filter dP (a :: as))
>   s0 : Injective1 (getProof (filter dP (a :: as)))
>   s0 i j q with (filter dP as)
>     | (n' ** as') with (dP a)
>       | (Yes _) = ?liko
>       | (No  _) = s5 where
>         s5 : i = j
>         s5 = ?lala -- injectiveFilterLemma dP as (injectiveTailLemma1 (a :: as) iaas) i j q
> -}

> {-
> ||| |filterTagSigma| preserves injectivity
> injectiveFilterTagSigmaLemma : {A : Type} ->
>                                {P : A -> Type} ->
>                                (dP : Dec1 P) ->
>                                (as : Vect n A) ->
>                                Injective1 as ->
>                                Injective1 (getProof (filterTagSigma d1P as))
> injectiveFilterTagSigmaLemma {n = Z}   dP Nil i1as i j p = absurd i

> ||| |filterTagSubset| preserves injectivity
> injectiveFilterTagSubsetLemma : {A : Type} ->
>                                 {P : A -> Type} ->
>                                 (dP : Dec1 P) ->
>                                 (as : Vect n A) ->
>                                 Injective1 as ->
>                                 Injective1 (getProof (filterTagSubset d1P as))
> injectiveFilterTagSubsetLemma {n = Z}   dP Nil i1as i j p = absurd i
> -}

Max and argmax

> |||
> maxLemma : {A : Type} -> {R : A -> A -> Type} ->
>            (tp : TotalPreorder R) ->
>            (a : A) -> (as : Vect n A) -> (p : LT Z n) -> a `Elem` as ->
>            R a (max tp as p)
> maxLemma {R} {n = Z}       tp a        Nil          p  _          = absurd p
> maxLemma {R} {n = S Z}     tp a (a  :: Nil)         _  Here       = reflexive tp a
> maxLemma {R} {n = S Z}     tp a (a' :: Nil)         _ (There prf) = absurd prf
> maxLemma {R} {n = S (S m)} tp a (a :: (a'' :: as))  _  Here with (argmaxMax tp (a'' :: as) (ltZS m))
>   | (k, max) with (totalPre tp a max)
>     | (Left  p) = p
>     | (Right _) = reflexive tp a
> maxLemma {R} {n = S (S m)} tp a (a' :: (a'' :: as)) _ (There prf) with (argmaxMax tp (a'' :: as) (ltZS m)) proof itsEqual
>   | (k, max) with (totalPre tp a' max)
>     | (Left  _) = replace {P = \rec => R a (snd rec)}
>                           (sym itsEqual)
>                           (maxLemma {n = S m} tp a (a'' :: as) (ltZS m) prf)
>     | (Right p) = s3 where
>       s1 : R a (snd (Vect.Operations.argmaxMax tp (a'' :: as) (ltZS m)))
>       s1 = maxLemma {n = S m} tp a (a'' :: as) (ltZS m) prf
>       s2 : R (snd (Vect.Operations.argmaxMax tp (a'' :: as) (ltZS m))) a'
>       s2 = replace {P = \rec => R (snd rec) a'} itsEqual p
>       s3 : R a a'
>       s3 = transitive tp a (snd (Vect.Operations.argmaxMax tp (a'' :: as) (ltZS m))) a' s1 s2
> %freeze maxLemma

> |||
> argmaxLemma : {A : Type} -> {R : A -> A -> Type} ->
>               (tp : TotalPreorder R) ->
>               (as : Vect n A) -> (p : LT Z n) ->
>               index (argmax tp as p) as = max tp as p
> argmaxLemma {n = Z}       tp  Nil              p = absurd p
> argmaxLemma {n = S Z}     tp (a :: Nil)        p = Refl
> argmaxLemma {n = S (S m)} tp (a' :: (a'' :: as)) p with (argmaxMax tp (a'' :: as) (ltZS m)) proof itsEqual
>   | (k, max') with (totalPre tp a' max')
>     | (Left   _) = assert_total (replace {P = \rec => Data.Vect.index (fst rec) (a'' :: as) = snd rec}
>                                          (sym itsEqual)
>                                          (argmaxLemma tp (a'' :: as) (ltZS m)))
>     | (Right  _) = Refl
> %freeze argmaxLemma

> |||
> maxElemLemma : {A : Type} -> {R : A -> A -> Type} ->
>                (tp : TotalPreorder R) ->
>                (as : Vect n A) -> (p : LT Z n) ->
>                Elem (max tp as p) as
> maxElemLemma {n = Z}       tp  Nil                p = absurd p
> maxElemLemma {n = S Z}     tp (a :: Nil)          p = Here
> maxElemLemma {n = S (S m)} tp (a' :: (a'' :: as)) p with (argmaxMax tp (a'' :: as) (ltZS m)) proof itsEqual
>   | (k, max) with (totalPre tp a' max)
>     | (Left   _) = assert_total (replace {P = \ ZUZU => Elem ZUZU (a' :: (a'' :: as))}
>                                          (cong {f = Prelude.Basics.snd} (sym itsEqual))
>                                          (There {y = a'} (maxElemLemma tp (a'' :: as) (ltZS m))))
>     | (Right  _) = Here
> %freeze maxElemLemma

> {-

> |||
> maxLemma : {A : Type} ->
>            (tp : TotalPreorder A) ->
>            (a : A) -> (as : Vect n A) -> (p : LT Z n) -> a `Elem` as ->
>            R tp a (max tp as p)
> maxLemma {n = Z}       tp a        Nil          p  _          = absurd p
> maxLemma {n = S Z}     tp a (a  :: Nil)         _  Here       = reflexive tp a
> maxLemma {n = S Z}     tp a (a' :: Nil)         _ (There prf) = absurd prf
> maxLemma {n = S (S m)} tp a (a :: (a'' :: as))  _  Here with (argmaxMax tp (a'' :: as) (ltZS m))
>   | (k, max) with (totalPre tp a max)
>     | (Left  p) = p
>     | (Right _) = reflexive tp a
> maxLemma {n = S (S m)} tp a (a' :: (a'' :: as)) _ (There prf) with (argmaxMax tp (a'' :: as) (ltZS m)) proof itsEqual
>   | (k, max) with (totalPre tp a' max)
>     | (Left  _) = replace {P = \rec => R tp a (snd rec)}
>                           (sym itsEqual)
>                           (maxLemma {n = S m} tp a (a'' :: as) (ltZS m) prf)
>     | (Right p) = s3 where
>       s1 : R tp a (snd (Vect.Operations.argmaxMax tp (a'' :: as) (ltZS m)))
>       s1 = maxLemma {n = S m} tp a (a'' :: as) (ltZS m) prf
>       s2 : R tp (snd (Vect.Operations.argmaxMax tp (a'' :: as) (ltZS m))) a'
>       s2 = replace {P = \rec => R tp (snd rec) a'} itsEqual p
>       s3 : R tp a a'
>       s3 = transitive tp a (snd (Vect.Operations.argmaxMax tp (a'' :: as) (ltZS m))) a' s1 s2
> %freeze maxLemma

> |||
> argmaxLemma : {A : Type} ->
>               (tp : TotalPreorder A) ->
>               (as : Vect n A) -> (p : LT Z n) ->
>               index (argmax tp as p) as = max tp as p
> argmaxLemma {n = Z}       tp  Nil              p = absurd p
> argmaxLemma {n = S Z}     tp (a :: Nil)        p = Refl
> argmaxLemma {n = S (S m)} tp (a' :: (a'' :: as)) p with (argmaxMax tp (a'' :: as) (ltZS m)) proof itsEqual
>   | (k, max') with (totalPre tp a' max')
>     | (Left   _) = assert_total (replace {P = \rec => Data.Vect.index (fst rec) (a'' :: as) = snd rec}
>                                          (sym itsEqual)
>                                          (argmaxLemma tp (a'' :: as) (ltZS m)))
>     | (Right  _) = Refl
> %freeze argmaxLemma

> |||
> maxElemLemma : {A : Type} ->
>                (tp : TotalPreorder A) ->
>                (as : Vect n A) -> (p : LT Z n) ->
>                Elem (max tp as p) as
> maxElemLemma {n = Z}       tp  Nil                p = absurd p
> maxElemLemma {n = S Z}     tp (a :: Nil)          p = Here
> maxElemLemma {n = S (S m)} tp (a' :: (a'' :: as)) p with (argmaxMax tp (a'' :: as) (ltZS m)) proof itsEqual
>   | (k, max) with (totalPre tp a' max)
>     | (Left   _) = assert_total (replace {P = \ ZUZU => Elem ZUZU (a' :: (a'' :: as))}
>                                          (cong {f = Prelude.Basics.snd} (sym itsEqual))
>                                          (There {y = a'} (maxElemLemma tp (a'' :: as) (ltZS m))))
> {-
>     | (Left   _) = s4 where
>       s1 : Elem (snd (argmaxMax tp (a'' :: as) (ltZS m))) (a' :: (a'' :: as))
>       s1 = There {y = a'} (maxElemLemma tp (a'' :: as) (ltZS m))
>       s2 : argmaxMax tp (a'' :: as) (ltZS m) = (k, max)
>       s2 = sym itsEqual
>       s3 : snd (argmaxMax tp (a'' :: as) (ltZS m)) = max
>       s3 = cong {f = Prelude.Basics.snd} s2
>       s4 : Elem max (a' :: (a'' :: as))
>       s4 = replace {P = \ ZUZU => Elem ZUZU (a' :: (a'' :: as))} s3 s1
> -}
>     | (Right  _) = Here
> %freeze maxElemLemma

> -}

> {-

> |||
> maxLemma : {A : Type} -> {TO : A -> A -> Type} -> Preordered A TO =>
>            (a : A) -> (as : Vect (S n) A) -> a `Elem` as ->
>            TO a (max as)
> maxLemma {TO} {n = Z}   a (a :: Nil)          Here       = reflexive a
> maxLemma {TO} {n = Z}   a (a' :: Nil)        (There prf) = absurd prf
> maxLemma {TO} {n = S m} a (a :: (a'' :: as))  Here with (preorder a (max (a'' :: as)))
>   | (Left  p) = p
>   | (Right _) = reflexive a
> maxLemma {TO} {n = S m} a (a' :: (a'' :: as)) (There prf) with (preorder a' (max (a'' :: as)))
>   | (Left  _) = maxLemma a (a'' :: as) prf
>   | (Right p) = s3 where
>     s1 : TO a (max (a'' :: as))
>     s1 = maxLemma a (a'' :: as) prf
>     s2 : TO (max (a'' :: as)) a'
>     s2 = p
>     s3 : TO a a'
>     s3 = transitive a (max (a'' :: as)) a' s1 s2

> |||
> argmaxLemma : {A : Type} -> {TO : A -> A -> Type} -> Preordered A TO =>
>               (as : Vect (S n) A) ->
>               index (argmax as) as = max as
> argmaxLemma {TO} {n = Z}   (a :: Nil) = Refl
> argmaxLemma {TO} {n = S m} (a :: (a' :: as)) with (preorder a (max (a' :: as)))
>   | (Left   _) = argmaxLemma (a' :: as)
>   | (Right  _) = Refl

> -}

> {-

> |||
> maxLemma : {A, F : Type} -> {TO : F -> F -> Type} -> Ordered F TO =>
>            (af : (A,F)) -> (afs : Vect (S n) (A,F)) -> af `Elem` afs ->
>            TO (snd af) (max afs)
> maxLemma {A} {F} {TO} {n = Z}   af (af :: Nil)   Here       = reflexive (snd af)
> maxLemma {A} {F} {TO} {n = Z}   af (af' :: Nil) (There prf) = absurd prf
> maxLemma {A} {F} {TO} {n = S m} af (af :: (af'' :: afs)) Here with (order (snd af) (snd (argmaxMax (af'' :: afs))))
>   | (Left  p) = p
>   | (Right _) = reflexive (snd af)
> maxLemma {A} {F} {TO} {n = S m} af (af' :: (af'' :: afs)) (There prf) with (order (snd af') (snd (argmaxMax (af'' :: afs))))
>   | (Left  _) = maxLemma {A} {F} {TO} {n = m} af (af'' :: afs) prf
>   | (Right p) = s3 where
>     s1 : TO (snd af) (max (af'' :: afs))
>     s1 = maxLemma {A} {F} {TO} {n = m} af (af'' :: afs) prf
>     s2 : TO (max (af'' :: afs)) (snd af')
>     s2 = p
>     s3 : TO (snd af) (snd af')
>     s3 = transitive (snd af) (VectOperations.max (af'' :: afs)) (snd af') s1 s2

> -}


||| Position and geometry of Hexagonal grid system
||| https://www.redblobgames.com/grids/hexagons/
module Bautzen.Pos

import Data.Fin
import Data.Nat
import Data.Nat.DivMod
import Data.Nat.Parity
import Decidable.Equality
import Data.List

import public Data.ZZ
import public Data.ZZ.Extra

%default total

-- Positions & Map

||| A position/hex of the game board encoded as a pair of `Fin`s.
||| The type is indexed by the bounds on the number of rows and cols
||| which are basically dependent on the size of the terrain.
public export
data Loc : (c : Nat) -> (r : Nat) -> Type where
  Hex : (col : Fin c) -> (row : Fin r) -> Loc c r

colInjective : Hex c r = Hex col r' -> c = col
colInjective Refl = Refl

rowInjective : Hex c r = Hex c' row -> r = row
rowInjective Refl = Refl

public export
Eq (Loc c r) where
  (==) (Hex col row) (Hex col' row') = col == col' && row == row'

public export
DecEq (Loc c r) where
  decEq (Hex col row) (Hex k j ) with (decEq col k)
    decEq (Hex col row) (Hex k j ) | No contra = No $ \ h => contra (colInjective h)
    decEq (Hex col row) (Hex k j ) | Yes p with (decEq row j)
      decEq (Hex col row) (Hex k j ) | Yes p | No contra = No $ \ h => contra (rowInjective h)
      decEq (Hex col row) (Hex col row) | Yes Refl | Yes Refl = Yes Refl

public export
Show (Loc c r) where
  show (Hex c r) = "Hex " ++ show2Digits (finToNat c) ++ " " ++ show2Digits (finToNat r)
    where
      show2Digits : Nat -> String
      show2Digits n =
        if n <= 9
        then "0" ++ show n
        else show n

public export
Ord (Loc c r) where
  compare (Hex col row) (Hex col' row') =
    case compare col col' of
      LT => LT
      EQ => compare row row'
      GT => GT

||| Cube coordinates.
||| Cube coordinates stem from the observation a 2-D hexagonal grid is equivalent
||| to a diagonal "slice" of a 3-D cubic grid. Using cubic coordinates makes it
||| much easier to compute geometric values.
||| We only store the `x` (column) and `z` (depth) coordinates instead
||| of a triple as the `y` dimension can be simply recovered as `-x -z`.
public export
data Cube : Type where
  MkCube : (x : ZZ) -> (z : ZZ) -> Cube

||| Compute the L1 distance between 2 `Cube`s
||| see [Red Blob Games](https://www.redblobgames.com/grids/hexagons/#distances-cube) page
||| for details on the (pretty cool) algorithm.
public export
cubeDistance : Cube -> Cube -> Nat
cubeDistance (MkCube x z) (MkCube x' z') =
  let y  = negate x - z
      y' = negate x' - z'
  in max (max (absZ (x - x')) (absZ (y - y'))) (absZ (z - z'))

public export
posToCube : Loc c r -> Cube
posToCube (Hex col row) =
  let x = Pos (finToNat col)
      sign : ZZ
      sign = if odd (finToNat col) then 1 else 0
      z : ZZ
      z = Pos (finToNat row) - divZZNZ (x - sign) 2 {z = PosSIsNotZ }
  in MkCube x z

mutual
  public export
  data Distance : Type where
    IsDistance : (d : Nat) -> Distance

  export
  Num Distance where
    fromInteger = IsDistance . fromInteger
    IsDistance d1 * IsDistance d2 = IsDistance $ d1 * d2 -- meaningless
    IsDistance d1 + IsDistance d2 = IsDistance $ d1 + d2

  public export
  distance : {c : Nat} -> {r : Nat} -> Loc c r -> Loc c r -> Distance
  distance x y = IsDistance (cubeDistance (posToCube x) (posToCube y))

public export
data Mvmt : Type where
  Dec : Mvmt
  Neut : Mvmt
  Inc : Mvmt

public export
succNotLTEZ : Not (LTE (S m) Z)
succNotLTEZ LTEZero impossible

public export
fromLTESucc : LTE (S m) (S n) -> LTE m n
fromLTESucc (LTESucc x) = x

public export
lteSuccR : LTE n m -> LTE n (S m)
lteSuccR LTEZero     = LTEZero
lteSuccR (LTESucc x) = LTESucc (lteSuccR x)

public export
lteSuccL : LTE (S n) m -> LTE n m
lteSuccL (LTESucc x) = lteSuccR x

public export
isLte : (m, n : Nat) -> Dec (LTE m n)
isLte Z n = Yes LTEZero
isLte (S k) Z = No succNotLTEZ
isLte (S k) (S j)
    = case isLte k j of
           No contra => No (contra . fromLTESucc)
           Yes prf => Yes (LTESucc prf)

public export
shiftLoc : {bound : Nat} -> (x : Nat) -> Mvmt -> Maybe (Fin bound)
shiftLoc Z Dec = Nothing
shiftLoc (S k) Dec = natToFin k bound
shiftLoc x Neut = natToFin x bound
shiftLoc x Inc {bound} = natToFin (S x) bound

public export
makeLoc : {c : Nat} -> {r : Nat} -> (x : Nat) -> (y : Nat) -> (Mvmt, Mvmt) -> Maybe (Loc c r)
makeLoc col row (a, b) = do
  c' <- shiftLoc col a
  r' <- shiftLoc row b
  pure $ Hex c' r'

public export
oddShifts : List (Mvmt, Mvmt)
oddShifts = [ (Dec, Neut)
            , (Neut, Dec)
            , (Inc, Neut)
            , (Inc, Inc)
            , (Neut, Inc)
            , (Dec, Inc)
            ]

public export
evenShifts : List (Mvmt, Mvmt)
evenShifts = [ (Dec, Dec)
            , (Neut, Dec)
            , (Inc, Dec)
            , (Inc, Neut)
            , (Neut, Inc)
            , (Dec, Neut)
            ]

neighbours' : {col : Nat} -> {row : Nat} -> (x : Nat) -> (y : Nat) -> List (Loc col row)
neighbours' x y with (x `divMod` (S Z))
  neighbours' x@(Z + (q * 2)) y     | (MkDivMod q Z _) = catMaybes $ map (makeLoc x y) evenShifts
  neighbours' x@((S r) + (q * 2)) y | (MkDivMod q (S r) _) = catMaybes $ map (makeLoc x y) oddShifts
  neighbours' (S (S r) + (q * 2)) _ | (MkDivMod q (S (S r)) LTEZero) impossible

||| Compute the neighbours of a given position
||| There are at most 6 neighbours, with side and corner hexes having of
||| course less.
public export
neighbours : {c : Nat} -> {r : Nat} -> (pos : Loc c r) -> List (Loc c r)
neighbours (Hex col row) = neighbours' (finToNat col) (finToNat row)

namespace LocTest

  neighbours1_test : (neighbours {c=22} {r=12} (Hex 3 3) = [ Hex 2 3, Hex 3 2, Hex 4 3, Hex 4 4, Hex 3 4, Hex 2 4] )
  neighbours1_test = Refl

  neighbours_test : (neighbours {c=22} {r=12} (Hex 2 2) = [ Hex 1 1, Hex 2 1, Hex 3 1, Hex 3 2, Hex 2 3, Hex 1 2] )
  neighbours_test = Refl

  distance_to_odd_neighbours_is_1 : map (distance (Hex 3 2)) (neighbours {c=22} {r=12} (Hex 3 2)) = [ 1, 1, 1, 1, 1, 1 ]
  distance_to_odd_neighbours_is_1 = Refl

  distance_to_even_neighbours_is_1 : map (distance (Hex 2 2)) (neighbours {c=22} {r=12} (Hex 2 2)) = [ 1, 1, 1, 1, 1, 1 ]
  distance_to_even_neighbours_is_1 = Refl

  distance_test : distance {c=22} {r=12} (Hex 3 2) (Hex 4 4) = 2
  distance_test = Refl


module Data.Functor.Representable

import Data.Vect
import Data.Vect.Extra

%default total

public export
interface Functor f => Representable f rep | f where
  index : f a -> rep -> a
  tabulate : (rep -> a) -> f a

public export
[Compose] Representable f rep => Representable g rep' => Representable (f . g) (rep, rep') using Functor.Compose where
  index x (i, j) = (x `index` i) `index` j
  tabulate = map tabulate . tabulate . curry

public export
{n : Nat} -> Representable (Vect n) (Fin n) where
  index = flip index
  tabulate f = mapWithIndex (\i, () => f i) $ replicate n ()


module Data.Compress.Utils.FiniteBuffer

import Data.Seq.Unsized

export
record FiniteBuffer a where
  constructor FB
  max_size : Int
  size : Int
  buffer : Seq a

export
empty : Nat -> FiniteBuffer a
empty n = FB (cast n) 0 empty

export
take_last : Nat -> FiniteBuffer a -> Maybe (List a)
take_last n fb = guard (cast n <= fb.size) $> (toList $ take n $ drop (cast (fb.size - cast n)) fb.buffer)

infixr 5 +<
infixr 5 +<><

export
(+<) : FiniteBuffer a -> a -> FiniteBuffer a
(FB max_size size buffer) +< x =
  let
    len = size + 1
    buf = snoc buffer x
  in
    if len > max_size then FB max_size max_size $ tail buf else FB max_size len buf

export
(+<><) : Foldable f => FiniteBuffer a -> f a -> FiniteBuffer a
buf +<>< elems = foldl (+<) buf elems

export
length : FiniteBuffer a -> Nat
length = cast . size


module Control.Monad.Logic

import public Control.Monad.Identity
import public Control.Monad.Logic.Interface
import public Control.Monad.Logic.Logic


foldlA : (a -> b -> a) -> a -> Vector (x::xs) b -> a
foldlA f e v with (flattenA v)
   | (_ ** v') = foldlA' f e v'
     where foldlA' : (a -> b -> a) -> a -> Vector [(S ys)] b -> a
           foldlA' f e v = foldl f e v


module Main

import System

readNumber : IO (Maybe Nat)
readNumber = do
  input <- getLine
  if all isDigit (unpack input)
     then pure (Just (cast input))
     else pure Nothing

countdown : (secs : Nat) -> IO ()
countdown Z = putStrLn "Lift off!"
countdown (S secs) = do putStrLn (show (S secs))
                        usleep 1000000
                        countdown secs

countdowns : IO ()
countdowns = do putStr "Enter starting number: "
                Just startNum <- readNumber
                    | Nothing => do putStrLn "Invalid input"
                                    countdowns
                countdown startNum
                putStrLn "Another (y/n)? "
                yn <- getLine
                if yn == "y" then countdowns
                             else pure ()


module Control.Effect.Writer

import Control.EffectAlgebra

import Control.Monad.Writer

||| Writer effect.
public export
data WriterE : Type -> (Type -> Type) -> Type -> Type where
  Tell : w -> WriterE w m ()

export
Functor (\w => WriterE w m a) where
  map f (Tell x) = Tell (f x)

||| Write the value to the context within a monadic computation that supports it.
public export
tell : Inj (WriterE w) sig => Algebra sig m => w -> m ()
tell s = send (Tell s)

namespace Algebra
  ||| Successive writes overwrite the preceding state.
  public export
  [Overwrite] Algebra sig m => Algebra (WriterE s :+: sig) (WriterT s m) where
    alg ctx hdl (Inl (Tell s)) = MkWriterT $ \_ => pure (ctx, s)
    alg ctxx hdl (Inr x) = MkWriterT $ \r => do
     res <- alg
       {f = Functor.Compose @{(Functor.LeftPair, %search)}}
       (ctxx, r) h x
     pure res
     where
      h : Handler ((,s) . ctx) n m
      h =
         (~<~) {g = Functor.LeftPair}
          {ctx1 = (,s), ctx2 = ctx}
          {l = n}
          {m = WriterT s m} {n = m} (uncurry unWriterT) hdl

  ||| Newer writes are concatenated from the left, via the `Monoid` instance.
  public export
  [ConcatLeft] Monoid s => Algebra sig m => Algebra (WriterE s :+: sig) (WriterT s m) where
    alg ctxx hdl (Inl (Tell s)) = MkWriterT $ \s' => pure (ctxx, (s <+> s'))
    alg ctxx hdl (Inr x) = MkWriterT $ \r => do
     -- hdl : Hander ctx n (WriterT s m)
     -- h : Handler (,s) (WriterT s m) m
     -- h ~<~ hdl : Handler ((, s) . ctx) n m
     res <- alg
       {f = Functor.Compose @{(Functor.LeftPair, %search)}}
       (ctxx, r) h x
     pure res
     where
      h : Handler ((,s) . ctx) n m
      h =
         (~<~) {g = Functor.LeftPair}
          {ctx1 = (,s), ctx2 = ctx}
          {l = n}
          {m = WriterT s m} {n = m} (uncurry unWriterT) hdl


> module Opt.Operations

> import Control.Isomorphism
> import Data.Fin
> import Data.Vect
> import Syntax.PreorderReasoning

> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Rel.TotalPreorder
> import Rel.TotalPreorderOperations
> import Vect.Operations
> import Vect.Properties
> import Fun.Operations
> import Nat.LTProperties

> %default total

> %access public export

> |||
> argmaxMax : {A, B : Type} -> {R : B -> B -> Type} ->
>             TotalPreorder R ->
>             (fA : Finite A) ->
>             (ne : CardNotZ fA) ->
>             (f : A -> B) -> (A, B)
> argmaxMax {A} {B} tp fA nefA f = max (extendLeftLemma tp) abs ltZn where
>   n    : Nat
>   n    = card fA
>   ltZn : LT Z n
>   ltZn = notZisgtZ nefA
>   abs  : Vect n (A,B)
>   abs  = map (pair (id, f)) (toVect fA)

> |||
> max : {A, B : Type} -> {R : B -> B -> Type} ->
>       TotalPreorder R ->
>       (fA : Finite A) ->
>       (ne : CardNotZ fA) ->
>       (f : A -> B) -> B
> max tp fA nefA f = snd (argmaxMax tp fA nefA f)

> |||
> argmax : {A, B : Type} -> {R : B -> B -> Type} ->
>          TotalPreorder R ->
>          (fA : Finite A) ->
>          (ne : CardNotZ fA) ->
>          (f : A -> B) -> A
> argmax tp fA nefA f = fst (argmaxMax tp fA nefA f)

> |||
> maxSpec : {A, B : Type} -> {R : B -> B -> Type} ->
>           (tp : TotalPreorder R) ->
>           (fA : Finite A) ->
>           (nefA : CardNotZ fA) ->
>           (f : A -> B) ->
>           (a : A) -> R (f a) (max tp fA nefA f)
> maxSpec {A} {B} {R} tp fA nefA f a = s4 where
>   n    : Nat
>   n    = card fA
>   ltZn : LT Z n
>   ltZn = notZisgtZ nefA
>   abs  : Vect n (A,B)
>   abs  = map (pair (id, f)) (toVect fA)
>   s1   : Elem (a, f a) abs
>   s1   = mapLemma (toVect fA) (pair (id, f)) a (toVectComplete fA a)
>   s2   : (extendLeft R) (a, f a) (max (extendLeftLemma tp) abs ltZn)
>   s2   = maxLemma (extendLeftLemma tp) (a, f a) abs ltZn s1
>   s3   : R (f a) (snd (max (extendLeftLemma tp) abs ltZn))
>   s3   = s2
>   s4   : R (f a) (max tp fA nefA f)
>   s4   = s3

> |||
> argmaxSpec : {A, B : Type} -> {R : B -> B -> Type} ->
>              (tp : TotalPreorder R) ->
>              (fA : Finite A) ->
>              (nefA : CardNotZ fA) ->
>              (f : A -> B) ->
>              (max tp fA nefA f) = f (argmax tp fA nefA f)
> argmaxSpec {A} {B} tp fA nefA f = s3 where
>   ab : (A,B)
>   ab = argmaxMax tp fA nefA f
>   s1 : Elem ab (map (pair (Prelude.Basics.id, f)) (toVect fA))
>   s1 = maxElemLemma (extendLeftLemma tp) (map (pair (id, f)) (toVect fA)) (notZisgtZ nefA)
>   s2 : f (fst ab) = snd ab
>   s2 = mapIdfLemma (toVect fA) f ab s1
>   s3 : max tp fA nefA f = f (argmax tp fA nefA f)
>   s3 = sym s2

> {-

> argmaxMax : {A, B : Type} ->
>             TotalPreorder B ->
>             (fA : Finite A) ->
>             (ne : CardNotZ fA) ->
>             (f : A -> B) -> (A, B)
> argmaxMax {A} {B} tp fA nefA f = max (fromTotalPreorder2 tp) abs ltZn where
>   n    : Nat
>   n    = card fA
>   ltZn : LT Z n
>   ltZn = notZisgtZ nefA
>   abs  : Vect n (A,B)
>   abs  = map (pair (id, f)) (toVect fA)

> max : {A, B : Type} ->
>       TotalPreorder B ->
>       (fA : Finite A) ->
>       (ne : CardNotZ fA) ->
>       (f : A -> B) -> B
> max tp fA nefA f = snd (argmaxMax tp fA nefA f)

> argmax : {A, B : Type} ->
>          TotalPreorder B ->
>          (fA : Finite A) ->
>          (ne : CardNotZ fA) ->
>          (f : A -> B) -> A
> argmax tp fA nefA f = fst (argmaxMax tp fA nefA f)

> maxSpec : {A, B : Type} ->
>           (tp : TotalPreorder B) ->
>           (fA : Finite A) ->
>           (nefA : CardNotZ fA) ->
>           (f : A -> B) ->
>           (a : A) -> R tp (f a) (max tp fA nefA f)
> maxSpec {A} {B} tp fA nefA f a = s4 where
>   n    : Nat
>   n    = card fA
>   ltZn : LT Z n
>   ltZn = notZisgtZ nefA
>   abs  : Vect n (A,B)
>   abs  = map (pair (id, f)) (toVect fA)
>   s1   : Elem (a, f a) abs
>   s1   = mapLemma (toVect fA) (pair (id, f)) a (toVectComplete fA a)
>   s2   : (from2 (R tp)) (a, f a) (max (fromTotalPreorder2 tp) abs ltZn)
>   s2   = maxLemma (fromTotalPreorder2 tp) (a, f a) abs ltZn s1
>   s3   : R tp (f a) (snd (max (fromTotalPreorder2 tp) abs ltZn))
>   s3   = s2
>   s4   : R tp (f a) (max tp fA nefA f)
>   s4   = s3

> argmaxSpec : {A, B : Type} ->
>              (tp : TotalPreorder B) ->
>              (fA : Finite A) ->
>              (nefA : CardNotZ fA) ->
>              (f : A -> B) ->
>              (max tp fA nefA f) = f (argmax tp fA nefA f)
> argmaxSpec {A} {B} tp fA nefA f = s3 where
>   ab : (A,B)
>   ab = argmaxMax tp fA nefA f
>   s1 : Elem ab (map (pair (Prelude.Basics.id, f)) (toVect fA))
>   s1 = maxElemLemma (fromTotalPreorder2 tp) (map (pair (id, f)) (toVect fA)) (notZisgtZ nefA)
>   s2 : f (fst ab) = snd ab
>   s2 = mapIdfLemma (toVect fA) f ab s1
>   s3 : max tp fA nefA f = f (argmax tp fA nefA f)
>   s3 = sym s2

> {-

> argmaxMax : {A, B : Type} -> {TO : B -> B -> Type} ->
>             Preordered B TO =>
>             (fA : Finite A) -> (ne : CardNotZ fA) ->
>             (f : A -> B) -> (A,B)
> argmaxMax {A} {B} {TO} fA nefA f =
>   VectOperations.max {A = (A,B)} {TO = sndType TO} abs ltZn where
>     n    : Nat
>     n    = card fA
>     ltZn : LT Z n
>     ltZn = notZisgtZ nefA
>     abs  : Vect n (A,B)
>     abs  = map (pair (id, f)) (toVect fA)

> max : {A, B : Type} -> {TO : B -> B -> Type} ->
>       Preordered B TO =>
>       (fA : Finite A) -> (ne : CardNotZ fA) ->
>       (f : A -> B) -> B
> max fA nefA f = snd (argmaxMax fA nefA f)

> argmax : {A, B : Type} -> {TO : B -> B -> Type} ->
>          Preordered B TO =>
>          (fA : Finite A) -> (ne : CardNotZ fA) ->
>          (f : A -> B) -> A
> argmax fA nefA f = fst (argmaxMax fA nefA f)

> maxSpec : {A, B : Type} -> {TO : B -> B -> Type} ->
>           Preordered B TO =>
>           (fA : Finite A) -> (nefA : CardNotZ fA) ->
>           (f : A -> B) ->
>           (a : A) -> TO (f a) (max fA nefA f)
> maxSpec {A} {B} {TO} fA nefA f a = s4 where
>   n    : Nat
>   n    = card fA
>   ltZn : LT Z n
>   ltZn = notZisgtZ nefA
>   abs  : Vect n (A,B)
>   abs  = map (pair (id, f)) (toVect fA)
>   s1   : Elem (a, f a) abs
>   s1   = mapLemma (toVect fA) (pair (id, f)) a (toVectComplete fA a)
>   s2   : (sndType TO) (a, f a) (max abs ltZn)
>   s2   = maxLemma (a, f a) abs ltZn s1
>   s3   : TO (f a) (snd (max abs ltZn))
>   s3   = s2
>   s4   : TO (f a) (max fA nefA f)
>   s4   = s3

> argmaxSpec : {A, B : Type} -> {TO : B -> B -> Type} ->
>              Preordered B TO =>
>              (fA : Finite A) -> (nefA : CardNotZ fA) ->
>              (f : A -> B) ->
>              (max fA nefA f) = f (argmax fA nefA f)
> argmaxSpec {A} {B} fA nefA f = s3 where
>   ab : (A,B)
>   ab = argmaxMax fA nefA f
>   s1 : Elem ab (map (pair (id, f)) (toVect fA))
>   s1 = maxElemLemma (map (pair (id, f)) (toVect fA)) (notZisgtZ nefA)
>   s2 : f (fst ab) = snd ab
>   s2 = mapIdfLemma (toVect fA) f ab s1
>   s3 : max fA nefA f = f (argmax fA nefA f)
>   s3 = sym s2

> -}

> ---}


> module Real.Postulates

> %default total
> %access public export

* Reals

> ||| Real numbers
> postulate Real : Type

* Constants

> ||| Zero
> postulate zero : Real

* Operations

> |||
> postulate fromNat : Nat -> Real

> ||| Addition of real numbers
> postulate plus : Real -> Real -> Real

> ||| Multiplication of real numbers
> postulate mult : Real -> Real -> Real

> ||| Subtrantion of real numbers
> postulate minus : Real -> Real -> Real

> ||| Division of real numbers
> postulate div : Real -> Real -> Real

> ||| Division of real numbers
> postulate abs : Real -> Real

* Relations (as predicates)

> ||| Smaller or equal
> postulate LTE : Real -> Real -> Type

> ||| Greater then
> GT : Real -> Real -> Type
> GT x y = Not (x `LTE` y)

> {-

> ---}


module Control.Lens.Iso

import Control.Lens.Types
import Control.Monad.Identity
import Data.Profunctor

%default total

public export
data Exchange a b s t = MkExchange (s -> a) (b -> t)

public export
Functor (Exchange a b s) where
  map f (MkExchange sa bt) = MkExchange sa (f . bt)

public export
Profunctor (Exchange a b) where
  dimap f g (MkExchange sa bt) = MkExchange (sa . f) (g . bt)

  lmap f (MkExchange sa bt) = MkExchange (sa . f) bt

  rmap g (MkExchange sa bt) = MkExchange sa (g . bt)

public export
AnIso : Type -> Type -> Type -> Type -> Type
AnIso s t a b = Exchange a b a (Identity b) -> Exchange a b s (Identity t)

public export
AnIso' : Type -> Type -> Type
AnIso' = Simple AnIso

public export
iso : (s -> a) -> (b -> t) -> Iso s t a b
iso sa bt = dimap sa (map bt)

public export
withIso : AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso ai k = case ai (MkExchange id Id) of
    MkExchange sa bt => k sa (runIdentity . bt)

public export
from : AnIso s t a b -> Iso b a t s
from l = withIso l $ \sa,bt => iso bt sa


module Crypto.ChaCha

import Control.Monad.State
import Data.Bits
import Data.DPair
import Data.Fin
import Data.Fin.Extra
import Data.Nat.Order.Properties
import Data.Vect
import Utils.Bytes
import Utils.Misc

public export
Key : Type
Key = Vect 8 Bits32 -- 32 * 8 = 256

public export
ChaChaState : Type
ChaChaState = Vect 16 Bits32

-- The first four words (0-3) are constants
public export
constants : Vect 4 Bits32
constants = [0x61707865, 0x3320646e, 0x79622d32, 0x6b206574] -- ['expa', 'nd 3', '2-by', 'te k']

public export
quarter_rotate : Fin 16 -> Fin 16 -> Fin 16 -> Fin 16 -> State ChaChaState ()
quarter_rotate a b c d = do
  modify (\s => updateAt a (+ index b s) s)
  modify (\s => updateAt d (`xor` index a s) s)
  modify (\s => updateAt d (rotl 16) s)

  modify (\s => updateAt c (+ index d s) s)
  modify (\s => updateAt b (`xor` index c s) s)
  modify (\s => updateAt b (rotl 12) s)

  modify (\s => updateAt a (+ index b s) s)
  modify (\s => updateAt d (`xor` index a s) s)
  modify (\s => updateAt d (rotl 8) s)

  modify (\s => updateAt c (+ index d s) s)
  modify (\s => updateAt b (`xor` index c s) s)
  modify (\s => updateAt b (rotl 7) s)

public export
double_rotate : State ChaChaState ()
double_rotate = do
  quarter_rotate 0 4  8 12
  quarter_rotate 1 5  9 13
  quarter_rotate 2 6 10 14
  quarter_rotate 3 7 11 15
  ------------------------
  quarter_rotate 0 5 10 15
  quarter_rotate 1 6 11 12
  quarter_rotate 2 7  8 13
  quarter_rotate 3 4  9 14

public export
run2x : (n_double_rounds : Nat) -> ChaChaState -> ChaChaState
run2x n_double_rounds s =
  execState s $ do
    original <- get
    go last
    modify (zipWith (+) original)
  where
  go : Fin (S n_double_rounds) -> State ChaChaState ()
  go FZ = pure ()
  go (FS wit) = double_rotate *> go (weaken wit)

||| ChaCha construction with 4 octets counter and 12 octets nonce as per RFC8439
public export
chacha_rfc8439_block : Nat -> (counter : Bits32) -> Key -> Vect 3 Bits32 -> Vect 64 Bits8
chacha_rfc8439_block rounds counter key nonce = concat $ map (to_le {n = 4}) $ run2x rounds $ constants ++ key ++ [counter] ++ nonce

||| ChaCha construction with 8 octets counter and 8 octets nonce as per the original ChaCha specification
public export
chacha_original_block : Nat -> (counter : Bits64) -> Key -> Vect 2 Bits32 -> Vect 64 Bits8
chacha_original_block rounds counter key nonce = concat $ map (to_le {n = 4}) $ run2x rounds $ constants ++ key ++ split_word counter ++ nonce
  where
    split_word : Bits64 -> Vect 2 Bits32
    split_word a = [ cast a, cast (shiftR a 32) ]


||| A Reversed List
module Data.SnocList

import Decidable.Equality
import Data.List

%default total

infixl 7 <><
infixr 6 <>>

||| 'fish': Action of lists on snoc-lists
public export
(<><) : SnocList a -> List a -> SnocList a
sx <>< [] = sx
sx <>< (x :: xs) = sx :< x <>< xs

||| 'chips': Action of snoc-lists on lists
public export
(<>>) : SnocList a -> List a -> List a
Lin       <>> xs = xs
(sx :< x) <>> xs = sx <>> x :: xs

Cast (SnocList a) (List a) where
  cast sx = sx <>> []

Cast (List a) (SnocList a) where
  cast xs = Lin <>< xs

||| Transform to a list but keeping the contents in the spine order (term depth).
public export
asList : SnocList type -> List type
asList = (reverse . cast)

public export
Eq a => Eq (SnocList a) where
  (==) Lin Lin = True
  (==) (sx :< x) (sy :< y) = x == y && sx == sy
  (==) _ _ = False

public export
Ord a => Ord (SnocList a) where
  compare Lin Lin = EQ
  compare Lin (sx :< x) = LT
  compare (sx :< x) Lin = GT
  compare (sx :< x) (sy :< y)
    = case compare sx sy of
        EQ => compare x y
        c  => c

||| True iff input is Lin
public export
isLin : SnocList a -> Bool
isLin Lin = True
isLin (sx :< x) = False

||| True iff input is (:<)
public export
isSnoc : SnocList a -> Bool
isSnoc Lin     = False
isSnoc (sx :< x) = True

public export
(++) : (sx, sy : SnocList a) -> SnocList a
(++) sx Lin = sx
(++) sx (sy :< y) = (sx ++ sy) :< y

public export
length : SnocList a -> Nat
length Lin = Z
length (sx :< x) = length sx + 1

export
Show a => Show (SnocList a) where
  show xs = "[< " ++ show' "" xs ++ "]"
    where
      show' : String -> SnocList a -> String
      show' acc Lin       = acc
      show' acc (Lin :< x)= show x ++ acc
      show' acc (xs :< x) = show' (", " ++ show x ++ acc) xs

public export
Functor SnocList where
  map f Lin = Lin
  map f (sx :< x) = (map f sx) :< (f x)

public export
Semigroup (SnocList a) where
  (<+>) = (++)

public export
Monoid (SnocList a) where
  neutral = Lin

||| Check if something is a member of a list using the default Boolean equality.
public export
elem : Eq a => a -> SnocList a -> Bool
elem x Lin = False
elem x (sx :< y) = x == y || elem x sx


counts : String -> (Nat, Nat)
counts str =
  let numWords = length (words str)
      numChars = length str
  in
  (numWords, numChars)


module Dec

import Basic
import Unit
import Void
import Coproduct

import Path
import General

public export
Dec : Type -> Type
Dec a = a + Neg a

public export
DecEq : Type -> Type
DecEq a = (x, y : a) -> Dec (x == y)


module Crypto

import Control.Monad.State
import Crypto.RSA
import Crypto.Random
import Crypto.Random.C
import Crypto.AES.Common
import Crypto.AES.Small
import Crypto.AES.Big
import Crypto.Hash
import Crypto.Hash.HMAC
import Data.Vect
import Data.List1
import Utils.Bytes
import Utils.Misc

test_chacha : HasIO m => m ()
test_chacha = do
  drg <- new_chacha12_drg
  let a = evalState drg (random_bytes 1024)
  putStrLn $ show a

test_rsa : HasIO m => m Integer
test_rsa = do
  (pk, sk) <- generate_key_pair 1024
  let m = 42069
  let c = rsa_encrypt pk m
  rsa_decrypt_blinded sk c

test_aes_128_key : Vect 16 Bits8
test_aes_128_key =
  [ 0x2b, 0x7e, 0x15, 0x16, 0x28, 0xae, 0xd2, 0xa6, 0xab, 0xf7, 0x15, 0x88, 0x09, 0xcf, 0x4f, 0x3c ]

test_aes_192_key : Vect 24 Bits8
test_aes_192_key =
  [ 0x8e, 0x73, 0xb0, 0xf7, 0xda, 0x0e, 0x64, 0x52, 0xc8, 0x10, 0xf3, 0x2b, 0x80, 0x90, 0x79, 0xe5
  , 0x62, 0xf8, 0xea, 0xd2, 0x52, 0x2c, 0x6b, 0x7b ]

test_aes_256_key : Vect 32 Bits8
test_aes_256_key =
  [ 0x60, 0x3d, 0xeb, 0x10, 0x15, 0xca, 0x71, 0xbe, 0x2b, 0x73, 0xae, 0xf0, 0x85, 0x7d, 0x77, 0x81
  , 0x1f, 0x35, 0x2c, 0x07, 0x3b, 0x61, 0x08, 0xd7, 0x2d, 0x98, 0x10, 0xa3, 0x09, 0x14, 0xdf, 0xf4 ]

test_aes_plaintext : Vect 16 Bits8
test_aes_plaintext =
  [ 0x6b, 0xc1, 0xbe, 0xe2, 0x2e, 0x40, 0x9f, 0x96, 0xe9, 0x3d, 0x7e, 0x11, 0x73, 0x93, 0x17, 0x2a ]

test_aes_128_ciphertext : Vect 16 Bits8
test_aes_128_ciphertext =
  Small.encrypt_block AES128 test_aes_128_key test_aes_plaintext

test_aes_192_ciphertext : Vect 16 Bits8
test_aes_192_ciphertext =
  Small.encrypt_block AES192 test_aes_192_key test_aes_plaintext

test_aes_256_ciphertext : Vect 16 Bits8
test_aes_256_ciphertext =
  Small.encrypt_block AES256 test_aes_256_key test_aes_plaintext

test_aes_big_128_ciphertext : Vect 16 Bits8
test_aes_big_128_ciphertext =
  Big.encrypt_block AES128 test_aes_128_key test_aes_plaintext

test_aes_big_192_ciphertext : Vect 16 Bits8
test_aes_big_192_ciphertext =
  Big.encrypt_block AES192 test_aes_192_key test_aes_plaintext

test_aes_big_256_ciphertext : Vect 16 Bits8
test_aes_big_256_ciphertext =
  Big.encrypt_block AES256 test_aes_256_key test_aes_plaintext

||| test case where padding first bit would be set
test_rsa_pss : Maybe ()
test_rsa_pss =
  emsa_pss_verify {algo=Sha256}
    (mgf1 {algo=Sha256})
    32
    [ 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20
    , 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20
    , 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x54, 0x4c
    , 0x53, 0x20, 0x31, 0x2e, 0x33, 0x2c, 0x20, 0x73, 0x65, 0x72, 0x76, 0x65, 0x72, 0x20, 0x43, 0x65, 0x72, 0x74, 0x69, 0x66, 0x69, 0x63
    , 0x61, 0x74, 0x65, 0x56, 0x65, 0x72, 0x69, 0x66, 0x79, 0x00, 0x8b, 0xea, 0x0f, 0x13, 0xa1, 0xa0, 0xa2, 0x30, 0xfc, 0x94, 0xe4, 0x21
    , 0xf1, 0x21, 0x3a, 0x4e, 0x00, 0xed, 0x45, 0x39, 0xe6, 0x49, 0x04, 0xfe, 0x98, 0x55, 0x0c, 0x97, 0xa0, 0xa3, 0xaf, 0x34, 0x64, 0xcf
    , 0xa0, 0x35, 0x36, 0xcf, 0x60, 0x0a, 0x2f, 0x1e, 0x04, 0xe7, 0x0d, 0xe6, 0x04, 0x6d ]
    (0x18 ::: [ 0xf9, 0x15, 0x8c, 0x76, 0x0d, 0x2d, 0x7f, 0x57, 0x36, 0x01, 0x8e, 0x89, 0x33, 0x92, 0xdc, 0x04, 0xb2, 0x02, 0x46, 0x30, 0x8b
    , 0x06, 0xc8, 0x65, 0x94, 0x71, 0xac, 0x3c, 0x6f, 0xe2, 0x71, 0x2b, 0x11, 0xe6, 0x4c, 0x7d, 0x11, 0x1f, 0x5a, 0x82, 0x20, 0x3c, 0x7c
    , 0x29, 0x83, 0x43, 0x1a, 0xcf, 0xd8, 0xc4, 0x4c, 0xad, 0xfc, 0x78, 0xf0, 0xef, 0x16, 0x1b, 0x24, 0xbf, 0xa5, 0x16, 0x8a, 0x47, 0xe7
    , 0x1d, 0x60, 0xd2, 0x6b, 0x08, 0xfa, 0x37, 0xdc, 0x76, 0x42, 0x88, 0x7c, 0xa5, 0x91, 0x97, 0x69, 0xa7, 0xd5, 0x50, 0x66, 0x09, 0xb6
    , 0x8a, 0x12, 0x76, 0x6e, 0xd1, 0xa6, 0xb0, 0x9e, 0x6d, 0xe6, 0xf2, 0x8a, 0x79, 0x4c, 0x68, 0x29, 0x52, 0xdb, 0x53, 0x36, 0x9b, 0x49
    , 0xed, 0x21, 0xf2, 0x48, 0x1d, 0x0e, 0x9f, 0x92, 0x23, 0x96, 0x0b, 0xc4, 0x47, 0x94, 0xb5, 0xec, 0x13, 0x40, 0x75, 0xde, 0x14, 0x9c
    , 0xa6, 0xa7, 0x2c, 0x9f, 0xbf, 0xe3, 0x94, 0xde, 0xeb, 0x49, 0xdc, 0x6a, 0xdc, 0x30, 0xa3, 0x0c, 0xf5, 0x2e, 0xe6, 0x14, 0x3f, 0xe2
    , 0x98, 0x27, 0x14, 0x8d, 0x21, 0x92, 0x20, 0xaa, 0xfb, 0x4e, 0x08, 0xa5, 0xd4, 0x7c, 0x8a, 0xf2, 0xed, 0x75, 0xa7, 0x6c, 0x01, 0xa4
    , 0x18, 0x4c, 0x58, 0x12, 0x10, 0xff, 0x2d, 0xc5, 0x0f, 0x8d, 0xe5, 0xab, 0x56, 0xa9, 0x81, 0x7c, 0x87, 0x4d, 0x19, 0xa4, 0x37, 0x96
    , 0x5d, 0x82, 0x84, 0xaa, 0x44, 0xc0, 0x7f, 0x4f, 0x39, 0xf4, 0x5d, 0x0d, 0xeb, 0xda, 0x3e, 0x2c, 0xd3, 0xaf, 0xe9, 0xf5, 0x24, 0x1e
    , 0x38, 0xb7, 0x35, 0x09, 0xda, 0x62, 0xc1, 0x3b, 0x89, 0x5c, 0xa9, 0xcc, 0x76, 0xe6, 0xed, 0x7f, 0xc6, 0xe0, 0x3a, 0x73, 0x94, 0x33
    , 0xca, 0x60, 0xf0, 0x15, 0xc7, 0x79, 0x62, 0x69, 0x68, 0x4d, 0xfd, 0x49, 0x98, 0xbc ])
    2047


module Instances.Notation

import public Data.Vect
import public Data.Rel
import public Decidable.Decidable
import Common.Abbrev
import Common.Interfaces
import Specifications.DiscreteOrderedGroup
import Specifications.OrderedRing

%default total
%access public export

specifyMonoid : Ringops s => Type
specifyMonoid {s} = MonoidSpec {s} (+) Zero

specifyGroup : Ringops s => Type
specifyGroup {s} = GroupSpec {s} (+) Zero Ng

specifyPartialOrder : Decidable [s,s] leq => Type
specifyPartialOrder {leq} = PartialOrderSpec leq

specifyTotalOrder : Decidable [s,s] leq => Type
specifyTotalOrder {leq} = TotalOrderSpec leq

specifyPartiallyOrderedMagma : (Ringops s, Decidable [s,s] leq) => Type
specifyPartiallyOrderedMagma {leq} = PartiallyOrderedMagmaSpec (+) leq

specifyPartiallyOrderedGroup : (Ringops s, Decidable [s,s] leq) => Type
specifyPartiallyOrderedGroup {leq} = PartiallyOrderedGroupSpec (+) Zero Ng leq

specifyOrderedGroup : (Ringops s, Decidable [s,s] leq) => Type
specifyOrderedGroup {leq} = OrderedGroupSpec (+) Zero Ng leq

specifyDiscreteOrderedGroup : (Ringops s, Decidable [s,s] leq) => Type
specifyDiscreteOrderedGroup {leq} =
  DiscreteOrderedGroupSpec (+) Zero Ng leq One

specifyRing : Ringops s => Type
specifyRing {s} = RingSpec {s} (+) Zero Ng (*)

specifyPartiallyOrderedRing : (Ringops s, Decidable [s,s] leq) => Type
specifyPartiallyOrderedRing {leq} =
  PartiallyOrderedRingSpec (+) Zero Ng (*) leq

specifyOrderedRing : (Ringops s, Decidable [s,s] leq) => Type
specifyOrderedRing {leq} =
  OrderedRingSpec (+) Zero Ng (*) leq

specifyDiscreteOrderedRing : (Ringops s, Decidable [s,s] leq) => Type
specifyDiscreteOrderedRing {leq} =
  DiscreteOrderedRingSpec (+) Zero Ng (*) leq One