> module SequentialDecisionProblems.examples.Main

> import Decidable.Order

> import Data.List
> import Data.List.Quantifiers
> import Effects
> import Effect.Exception
> import Effect.StdIO

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.TabBackwardsInduction
> import SequentialDecisionProblems.Utils
> import SequentialDecisionProblems.NonDeterministicDefaults
> import SequentialDecisionProblems.CoreTheoryOptDefaults
> import SequentialDecisionProblems.FullTheoryOptDefaults
> import SequentialDecisionProblems.TabBackwardsInductionOptDefaults

> import SequentialDecisionProblems.examples.LeftAheadRight

> import List.Operations
> import List.Properties
> import BoundedNat.BoundedNat
> import BoundedNat.Operations
> import BoundedNat.Properties
> import Sigma.Sigma
> import Sigma.Operations
> import Nat.OperationsProperties
> import Nat.LTEProperties
> import Nat.LTProperties
> import Unit.Properties
> import Void.Properties
> import LocalEffect.Exception
> import LocalEffect.StdIO

> -- %default total
> %auto_implicits off

> -- %logging 5

Like "Example2.lidr", but now |step t x y| is empty in states
corresponding to |maxColumn|, no matter which |y| is selected! Thus,
such states are not viable for more than zero steps. Attemps at making
more than zero decision steps starting from |maxColumn| should be
detected and rejected.

* The decision process:

> maxColumn : Nat
> maxColumn = 10

> nColumns : Nat
> nColumns = S maxColumn

** States:

> SequentialDecisionProblems.CoreTheory.State t = LTB nColumns

** Controls:

> SequentialDecisionProblems.CoreTheory.Ctrl t x = LeftAheadRight

** Transition function:

> SequentialDecisionProblems.CoreTheory.nexts t (MkSigma Z prf) Left =
>   [MkSigma maxColumn (ltIdS maxColumn)]
> SequentialDecisionProblems.CoreTheory.nexts t (MkSigma (S n) prf) Left with (decLT (S n) maxColumn)
>   | (Yes p)     = [MkSigma n (ltLemma1 n nColumns prf)]
>   | (No contra) = []
> SequentialDecisionProblems.CoreTheory.nexts t (MkSigma n prf) Ahead with (decLT n maxColumn)
>   | (Yes p)     = [MkSigma n prf]
>   | (No contra) = []
> SequentialDecisionProblems.CoreTheory.nexts t (MkSigma n prf) Right with (decLT n maxColumn)
>   | (Yes p)     = [MkSigma (S n) (LTESucc p)]
>   | (No contra) = []

** |Val| and |LTE|:

> SequentialDecisionProblems.CoreTheory.Val =
>   Nat

> SequentialDecisionProblems.CoreTheory.plus =
>   Prelude.Nat.plus

> SequentialDecisionProblems.CoreTheory.zero =
>   Z

> SequentialDecisionProblems.CoreTheory.LTE =
>   Prelude.Nat.LTE

> SequentialDecisionProblems.FullTheory.reflexiveLTE =
>   Nat.LTEProperties.reflexiveLTE

> SequentialDecisionProblems.FullTheory.transitiveLTE =
>   Nat.LTEProperties.transitiveLTE

> SequentialDecisionProblems.FullTheory.monotonePlusLTE =
>   Nat.LTEProperties.monotoneNatPlusLTE

> SequentialDecisionProblems.CoreTheoryOptDefaults.totalPreorderLTE =
>   Nat.LTEProperties.totalPreorderLTE

** Reward function:

> SequentialDecisionProblems.CoreTheory.reward t x y (MkSigma c _) =
>   if c == Z
>   then (S Z)
>   else if (S c) == nColumns
>        then (S (S Z))
>        else Z

** Measure:

> SequentialDecisionProblems.CoreTheory.meas = sum
> SequentialDecisionProblems.FullTheory.measMon = sumMon

** |State| is finite:

> SequentialDecisionProblems.TabBackwardsInduction.finiteState t =
>   finiteLTB nColumns

** |Ctrl| is finite:

> SequentialDecisionProblems.Utils.finiteCtrl _ =
>   finiteLeftAheadRight

** Reachability:

> SequentialDecisionProblems.CoreTheory.Reachable x' = Unit
> SequentialDecisionProblems.CoreTheory.reachableSpec1 {t} x r y = all (nexts t x y) where
>   all : (xs : List (State (S t))) -> SequentialDecisionProblems.CoreTheory.All (Reachable {t' = S t}) xs
>   all Nil = Nil
>   all (x :: xs) = () :: (all xs)
> SequentialDecisionProblems.TabBackwardsInduction.decidableReachable x = decidableUnit

** Viability:

> nextsLemma0 : {t : Nat} ->
>               (x : State t) -> (outl x `LT` maxColumn) -> nexts t x Ahead = [x]
> nextsLemma0 {t} (MkSigma i prf) p with (decLT i maxColumn)
>   | (Yes _) = Refl
>   | (No contra) = void (contra p)

> nextsLemma1 : {t : Nat} ->
>               (x : State t) -> (outl x `LT` maxColumn) ->
>               SequentialDecisionProblems.CoreTheory.NotEmpty (nexts t x Ahead)
> nextsLemma1 {t} x prf with (decLT (outl x) maxColumn)
>   | (Yes p) = s3 where
>     s1 : SequentialDecisionProblems.CoreTheory.NotEmpty [x]
>     s1 = SequentialDecisionProblems.CoreTheory.elemNotEmptySpec0 x [x] Here
>     s2 : [x] = nexts t x Ahead
>     s2 = sym (nextsLemma0 x p)
>     s3 : SequentialDecisionProblems.CoreTheory.NotEmpty (nexts t x Ahead)
>     s3 = replace s2 s1
>   | (No contra) = void (contra prf)

> SequentialDecisionProblems.CoreTheory.Viable  Z    _ = Unit
> SequentialDecisionProblems.CoreTheory.Viable (S n) x with (decLT (outl x) maxColumn)
>   | (Yes _) = Unit
>   | (No  _) = Void

> viableLemma0 : {t : Nat} -> {x : State t} -> Viable Z x = Unit
> viableLemma0 = Refl

> viableLemma1 : {t : Nat} -> {n : Nat} -> {x : State t} ->
>                (outl x) `Prelude.Nat.LT` maxColumn -> Viable (S n) x = Unit
> viableLemma1 {t} {n} {x} prf with (decLT (outl x) maxColumn)
>   | (Yes _) = Refl
>   | (No contra) = void (contra prf)

> viableLemma2 : {t : Nat} -> {n : Nat} -> {x : State t} ->
>                Not ((outl x) `Prelude.Nat.LT` maxColumn) -> Viable (S n) x = Void
> viableLemma2 {t} {n} {x} prf with (decLT (outl x) maxColumn)
>   | (Yes p) = void (prf p)
>   | (No _) = Refl

> viableLemma : {t : Nat} -> {n : Nat} ->
>               (x : State t) ->
>               SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} n) (nexts t x Ahead)
> viableLemma {t} {n = Z} (MkSigma i prf) with (decLT i maxColumn)
>   | (Yes p) = res where
>     res : SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} Z) [MkSigma i prf]
>     res = v :: Nil where
>       v : Viable {t = S t} Z (MkSigma i prf)
>       v with (decLT i maxColumn)
>         | (Yes _) = MkUnit
>         | (No  contra) = void (contra p)
>   | (No  _) = Nil
> viableLemma {t} {n = S m} (MkSigma i prf) with (decLT i maxColumn)
>   | (Yes p) = res where
>     res : SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} (S m)) [MkSigma i prf]
>     res = v :: Nil where
>       v : Viable {t = S t} (S m) (MkSigma i prf)
>       v with (decLT i maxColumn)
>         | (Yes _) = MkUnit
>         | (No  contra) = void (contra p)
>   | (No  _) = Nil

> SequentialDecisionProblems.CoreTheory.viableSpec1 {t} {n} x v with (decLT (outl x) maxColumn)
>   | (Yes prf) = MkSigma Ahead (ne, av) where
>     ne : NotEmpty (nexts t x Ahead)
>     ne = nextsLemma1 x prf
>     av : SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} n) (nexts t x Ahead)
>     av = viableLemma x
>   | (No _) = void v

> SequentialDecisionProblems.Utils.finiteViable  Z    _ = finiteUnit
> SequentialDecisionProblems.Utils.finiteViable (S m) x with (decLT (outl x) maxColumn)
>   | (Yes p) = finiteUnit
>   | (No  c) = finiteVoid

> SequentialDecisionProblems.Utils.decidableViable  Z    _ = decidableUnit
> SequentialDecisionProblems.Utils.decidableViable (S m) x with (decLT (outl x) maxColumn)
>   | (Yes _) = decidableUnit
>   | (No  _) = decidableVoid

* The computation:

> SequentialDecisionProblems.Utils.showState = show @{ShowLTB}
> SequentialDecisionProblems.Utils.showCtrl = show

> computation : { [STDIO] } Eff ()
> computation =
>   do putStr ("enter number of steps:\n")
>      nSteps <- getNat
>      putStr ("enter initial column:\n")
>      x0 <- getLTB nColumns
>      case (decidableViable {t = Z} nSteps x0) of
>        (Yes v0) => do putStrLn ("computing optimal policies ...")
>                       ps   <- pure (tabTailRecursiveBackwardsInduction Z nSteps)
>                       putStrLn ("computing optimal controls ...")
>                       mxys <- pure (possibleStateCtrlSeqs x0 () v0 ps)
>                       putStrLn (show mxys)
>                       putStrLn ("done!")
>        (No _)   => putStrLn ("initial column non viable for " ++ cast {from = Int} (cast nSteps) ++ " steps")

> main : IO ()
> main = run computation

> {-

> ---}

-- Local Variables:
-- idris-packages: ("effects")
-- End:


module Data.ZZ.ModuloVerification

import Control.Algebra
import Classes.Verified

import Data.ZZ
import Control.Algebra.NumericInstances
import Control.Algebra.ZZVerifiedInstances
import Data.Matrix.AlgebraicVerified	-- For (groupDivisionAddLToSubR)

import Control.Algebra.ZZDivisors

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

-- For (groupDivisionAddLToSubR)
import Control.Algebra.DiamondInstances

{-
Table of contents

* ZZ algebraic theorems
* Lemmas for (modNatFnIsRemainder)
* (modNatFnIsRemainder)
	Generate proofs of the quotient-remainder relation for binary
	modulo operations on naturals from simpler properties.
* modZGen - generate a verified ZZ modulo from a verified Nat modulo.
-}

{-
ZZ algebraic theorems
-}

total
invertByNegativity : ZZ -> ZZ -> ZZ
invertByNegativity x (Pos y) = x
invertByNegativity x (NegS y) = inverse x

total
timesToAbs :
	(x, y : ZZ)
	-> (x `invertByNegativity` y) <.> y = x <.> Pos (absZ y)
timesToAbs (Pos x') (Pos y') = Refl
timesToAbs (Pos x') (NegS y') =
	trans ( cong {f=((inverse $ Pos x')<.>) . NegS}
		$ sym $ multOneRightNeutral y' )
	$ ringNegationCancelsWithMult (Pos x') (Pos (S y'))
timesToAbs (NegS x') (Pos y') = Refl
timesToAbs (NegS x') (NegS y') = rewrite multOneRightNeutral x' in Refl

{- (modNatFnIsRemainder) parameters -}

parameters (
	modNatFn : Nat -> Nat -> Nat
	, modNatFnIdModZero :
		(x : Nat)
		-> x `modNatFn` Z = x
	, modNatFnCharizLT :
		(x, m : Nat)
		-> (x `LT` m)
		-> x `modNatFn` m = x
	, modNatFnCharizGTE :
		(x, m : Nat)
		-> (m `plus` x) `modNatFn` m = x `modNatFn` m
	){

{-
Lemmas for (modNatFnIsRemainder)

* (modNatFnPreservesZero)
* What to do with induction on constructed quotient-remainder pairs.
-}

total
modNatFnPreservesZero :
	(m : Nat) -> Z `modNatFn` m = Z
modNatFnPreservesZero Z = modNatFnIdModZero Z
modNatFnPreservesZero (S predm) = modNatFnCharizLT Z (S predm) $ LTESucc LTEZero

total
modNatFnCharizModulusPlus2 :
	(x, m, k : Nat)
	-> x = (k `mult` m) `plus` (x `modNatFn` m)
	-> m `plus` x = (S k `mult` m) `plus` (x `modNatFn` m)
modNatFnCharizModulusPlus2 x m k pr
	= trans (cong {f=plus m} pr)
	$ plusAssociative m _ _

-- by (modNatFnCharizModulusPlus2) & (modNatFnCharizGTE)
total
modNatFnCharizModulusPlus :
	(x, m, k : Nat)
	-> x = (k `mult` m) `plus` (x `modNatFn` m)
	-> m `plus` x = (S k `mult` m) `plus` ((m `plus` x) `modNatFn` m)
modNatFnCharizModulusPlus x m k pr
	= trans (modNatFnCharizModulusPlus2 x m k pr)
	$ cong $ sym $ modNatFnCharizGTE x m

total
modNatFnLTToDiffZ :
	(x, m : Nat)
	-> (x `LT` m)
	-> (Z `mult` m) `plus` (x `modNatFn` m) = x
modNatFnLTToDiffZ = modNatFnCharizLT

{-
(modNatFnIsRemainder):
Proof of the quotient-remainder expression for (modNatFn)

Proof of the quotient-remainder expression
for any natural in terms of any modulus
-}

{-
Proof sketch:

Either x < m or x of the form m+x' for some x.
(lteToSumExpr)

If m+x' then (modNatFnCharizModulusPlus):

x = (k `mult` m) `plus` (x `modNatFn` m)
-> m `plus` x = (S k `mult` m) `plus` ((m `plus` x) `modNatFn` m)

so that (modNatFnCharizModulusPlus x' m)
applied to
the divisor-remainder factorization for x'
gives a divisor-remainder factorization for (m `plus` x')
which by transitivity with the proof (x = m `plus` x')
gives the divisor-remainder factorization for x.
wwtbd.

(multDistributesOverPlusRight), implicitly.
(modNatFnLTToDiffZ)

---

Totality:

This proof recurses from an (x) of the form (m+x') into (x') when (m <= x).
However, it only does so in cases where (m > 0).
Thus,
m + x' = x
==>
x' = x - m < x

---

Structure:

Note that the proof itself follows the recursion pattern of one modulo proof.

Thus, given a better modulo algorithm, there should be a corresponding
better proof of the quotient-remainder property.

-}

%reflection
modNatFnIsRemainder :
	(x, m : Nat)
	-> (d : Nat ** (d `mult` m) `plus` (x `modNatFn` m) = x)
modNatFnIsRemainder Z _ = (0 ** modNatFnPreservesZero _)
modNatFnIsRemainder x Z = (0 ** modNatFnIdModZero _)
modNatFnIsRemainder x m
	= either
		(\ltXM => (Z ** modNatFnLTToDiffZ x m ltXM))
		(\gteXM =>
			let gteXM' = lteRelToLTE $ either (Right . sym) Left gteXM
			in let xAsMPlus = lteToSumExpr x m gteXM'
			in let divremx' = modNatFnIsRemainder (getWitness xAsMPlus) m
			in let prevNatTChariz
				= modNatFnCharizModulusPlus
					(getWitness xAsMPlus)
					m
					(getWitness divremx')
					$ sym $ getProof divremx'
			in (S $ getWitness divremx'
				** sym
				$ trans (getProof xAsMPlus)
				$ trans prevNatTChariz
				$ rewrite (sym $ getProof xAsMPlus) in Refl))
	$ trichotomy x m

} {- (modNatFnIsRemainder) parameters -}

{- modZGen parameters -}
parameters (
	modN : Nat -> Nat -> Nat
	, quotientPartN : (x, m : Nat)
		-> (d : Nat ** (d `mult` m) `plus` (x `modN` m) = x)
	) {

total
modZGenFn2 : ZZ -> ZZ -> ZZ
modZGenFn2 x m = Pos (absZ x `modN` absZ m)

total
modZGenFn : ZZ -> ZZ -> ZZ
modZGenFn x@(Pos x') m = x `modZGenFn2` m
modZGenFn x@(NegS x') m = inverse $ inverse x `modZGenFn2` m

{-
Bug: Registers as "possibly not total due to recursive path" in self,
but the pattern-matching recursion graph is

case NegS
 |
 v
case Pos (no call to (modZGenQuot) from Pos)

-}
modZGenQuot : (x : ZZ) -> (m : ZZ)
	-> (x <-> (x `modZGenFn` m)) `quotientOverZZ` m
modZGenQuot x@(Pos x') m =
	let quotientPartN' = quotientPartN x' (absZ m)
	in let witty = Pos (getWitness quotientPartN') `invertByNegativity` m
	in (witty
		** groupDivisionAddLToSubR
			(witty <.> m)
			(x `modZGenFn` m)
			x
		$ trans (cong {f=(<+>(Pos $ x' `modN` absZ m))}
			$ timesToAbs (Pos $ getWitness quotientPartN') m)
		$ cong {f=Pos} $ getProof quotientPartN'
		)
modZGenQuot x@(NegS x') m =
	quotientOverZZtrans
	(inverse Algebra.unity
		**
		trans (ringOpIsDistributiveL (inverse Algebra.unity) (Pos $ S x') _)
		$ bileibniz (<+>)
			(cong $ plusZeroRightNeutral x')
			(trans (ringOpIsCommutative_ZZ _ _)
			$ cong {f=inverse . inverse . Pos . (\t => t `modN` absZ m) . S}
			$ sym $ multOneRightNeutral x'
			)
		)
	$ modZGenQuot (Pos $ S x') m

} {- modZGen parameters -}


> module Real.Properties

> import Real.Postulates

> %default total
> %access public export

* Implementations:

> ||| Real is an implementation of Num
> implementation [NumReal] Num Real where
>   (+) = plus
>   (*) = mult
>   fromInteger = fromNat . fromIntegerNat

> using implementation NumReal
>   ||| Real is an implementation of Neg
>   implementation [NegReal] Neg Real where
>     negate x = zero `minus` x
>     (-) = minus

> using implementation NumReal
>   ||| Real is an implementation of Fractional
>   implementation [FractionalReal] Fractional Real where
>     (/) = div

> using implementation NegReal
>   |||
>   minusLemma : {x : Real} -> x - x = 0

> {-

> ---}


module Sub06Apply36x9

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

-- 3(12x+3) --E[2,-4]--> 3x
e36x9To3x :
  (l:Nat) -> P (S (S (S (plus (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l))) (plus (plus l l) (plus l l)))))) 2 -> P l 2
e36x9To3x l prf =
  let prf2 = lvDown (S (S (S (plus (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l))) (plus (plus l l) (plus l l)))))) 2 prf in e36x9To3x' l prf2

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


module Prelude.Basics

import Builtin

%default total

public export
Not : Type -> Type
Not x = x -> Void

-----------------------
-- UTILITY FUNCTIONS --
-----------------------

||| Manually assign a type to an expression.
||| @ a the type to assign
||| @ x the element to get the type
public export %inline
the : (0 a : Type) -> (1 x : a) -> a
the _ x = x

||| Identity function.
public export %inline
id : (1 x : a) -> a           -- Hopefully linearity annotation won't
                              -- break equality proofs involving id
id x = x

||| Function that duplicates its input
public export
dup : a -> (a, a)
dup x = (x, x)

||| Constant function.  Ignores its second argument.
public export %inline
const : a -> b -> a
const x = \value => x

||| Function composition.
public export %inline
(.) : (b -> c) -> (a -> b) -> a -> c
(.) f g = \x => f (g x)

||| Takes in the first two arguments in reverse order.
||| @ f the function to flip
public export
flip : (f : a -> b -> c) -> b -> a -> c
flip f x y = f y x

||| Function application.
public export
apply : (a -> b) -> a -> b
apply f a = f a

public export
curry : ((a, b) -> c) -> a -> b -> c
curry f a b = f (a, b)

public export
uncurry : (a -> b -> c) -> (a, b) -> c
uncurry f (a, b) = f a b

-- $ is compiled specially to shortcut any tricky unification issues, but if
-- it did have a type this is what it would be, and it might be useful to
-- use directly sometimes (e.g. in higher order functions)
public export
($) : forall a, b . ((x : a) -> b x) -> (x : a) -> b x
($) f a = f a

-------------------
-- PROOF HELPERS --
-------------------

||| Equality is a congruence.
public export
cong : (0 f : t -> u) -> (1 p : a = b) -> f a = f b
cong f Refl = Refl

||| Two-holed congruence.
export
-- These are natural in equational reasoning.
cong2 : (0 f : t1 -> t2 -> u) -> (1 p1 : a = b) -> (1 p2 : c = d) -> f a c = f b d
cong2 f Refl Refl = Refl

--------------
-- BOOLEANS --
--------------

||| Boolean Data Type.
public export
data Bool = True | False

||| Boolean NOT.
public export
not : (1 b : Bool) -> Bool
not True = False
not False = True

||| Boolean AND only evaluates the second argument if the first is `True`.
public export
(&&) : (1 b : Bool) -> Lazy Bool -> Bool
(&&) True x = x
(&&) False x = False

||| Boolean OR only evaluates the second argument if the first is `False`.
public export
(||) : (1 b : Bool) -> Lazy Bool -> Bool
(||) True x = True
(||) False x = x

%inline
public export
intToBool : Int -> Bool
intToBool 0 = False
intToBool x = True


import Data.List

data Color = White | Yellow | Orange | Red | Green | Blue
data Piece = Up | Down | Left | Right | Front | Back -- только для наглядности
           | UpFL | UpFR | UpBL | UpBR | DownFL | DownFR | DownBL | DownBR
           | LeftFU | LeftFD | LeftBU | LeftBD | RightFU | RightFD | RightBU | RightBD
           | FrontUL | FrontUR | FrontDL | FrontDR | BackUL | BackUR | BackDL | BackDR

record Cube where
    constructor MkCube
    stickers : List Color
    pieces : List Piece
    groups : List ( -- список возможных поворотов
                   List ( -- список групп перемещений наклеек
                         List Piece)) -- группа перемещений наклеек
    blocks : List (List Piece)

cube1x1x1 : Cube
cube1x1x1 = MkCube [White, Yellow, Orange, Red, Green, Blue]
                   [Up, Down, Left, Right, Front, Back]
                   [ [ [Up, Back, Down, Front] ], -- x
                     [ [Up, Right, Down, Left] ], -- y
                     [ [Front, Right, Back, Left] ] ] -- z
                   []

cube2x2x2 : Cube
cube2x2x2 = MkCube [White, White, White, White, Yellow, Yellow, Yellow, Yellow,
                    Orange, Orange, Orange, Orange, Red, Red, Red, Red,
                    Green, Green, Green, Green, Blue, Blue, Blue, Blue]
                   [UpFL, UpFR, UpBL, UpBR, DownFL, DownFR, DownBL, DownBR,
                    LeftFU, LeftFD, LeftBU, LeftBD, RightFU, RightFD, RightBU, RightBD,
                    FrontUL, FrontUR, FrontDL, FrontDR, BackUL, BackUR, BackDL, BackDR]
                   [ [ [UpFL, BackUL, DownBL, FrontDL],
                       [UpFR, BackUR, DownBR, FrontDR],
                       [UpBL, BackDL, DownFL, FrontUL],
                       [UpBR, BackDR, DownFR, FrontUR],
                       [LeftFU, LeftBU, LeftBD, LeftFD],
                       [RightFU, RightBU, RightBD, RightFD] ], -- x
                     [ [UpFL, RightFU, DownFR, LeftFD],
                       [UpFR, RightFD, DownFL, LeftFU],
                       [UpBL, RightBU, DownBR, LeftBD],
                       [UpBR, RightBD, DownBL, LeftBU],
                       [FrontUL, FrontUR, FrontDR, FrontDL],
                       [BackUL, BackUR, BackDR, BackDL] ], -- y
                     [ [UpFL, BackUL, DownBL, FrontDL],
                       [UpBL, BackDL, DownFL, FrontUL],
                       [LeftFU, LeftBU, LeftBD, LeftFD] ] ] -- L
                   []

cube1x2x2 : Cube
cube1x2x2 = ?hole122
-- cube1x2x2 = record {blocks = []} cube2x2x2

toNat : Piece -> Nat
toNat Up = 0
toNat Down = 1
toNat Left = 2
toNat Right = 3
toNat Front = 4
toNat Back = 5
toNat UpFL = 0 -- zn as indexation list
toNat UpFR = 1
toNat UpBL = 2
toNat UpBR = 3
toNat DownFL = 4
toNat DownFR = 5
toNat DownBL = 6
toNat DownBR = 7
toNat LeftFU = 8
toNat LeftFD = 9
toNat LeftBU = 10
toNat LeftBD = 11
toNat RightFU = 12
toNat RightFD = 13
toNat RightBU = 14
toNat RightBD = 15
toNat FrontUL = 16
toNat FrontUR = 17
toNat FrontDL = 18
toNat FrontDR = 19
toNat BackUL = 20
toNat BackUR = 21
toNat BackDL = 22
toNat BackDR = 23

Cast Piece Nat where
    cast piece = toNat piece

Eq Piece where
    x == y = (toNat x) == (toNat y)

Cast (List Piece) (List Nat) where
    cast [] = []
    cast (x :: xs) = cast x :: cast xs

Cast (List (List Piece)) (List (List Nat)) where
    cast [] = []
    cast (x :: xs) = cast x :: cast xs

Eq (Nat, Color) where
    (n1,_) == (n2,_) = n1 == n2

Ord (Nat, Color) where
    compare (n1,_) (n2,_) = compare n1 n2

Show Color where
    show White = "White"
    show Yellow = "Yellow"
    show Orange = "Orange"
    show Red = "Red"
    show Green = "Green"
    show Blue = "Blue"

Show Cube where
    show cube = show (stickers cube)

rotate : Nat -> Cube -> Maybe Cube
rotate n cube =
    let group = indexT n (groups cube) in
        case checkBlocked group (blocks cube) of
            True => Nothing
            False => Just (record {stickers = multiperm (cast group) (stickers cube)} cube) where

    -- TODO stdlib
    indexT : Nat -> List (List a) -> List a
    indexT _ [] = []
    indexT Z (x :: xs) = x
    indexT (S k) (_ :: xs) = indexT k xs

    checkBlocked : List (List Piece) -> List (List Piece) -> Bool
    checkBlocked xs ys = alienElem (flat xs) (flat ys) where

        -- TODO stdlib
        flat : List (List a) -> List a
        flat [] = []
        flat ([] :: xxs) = flat xxs
        flat (l@(x :: xs) :: xxs) = l ++ flat xxs

        -- TODO stdlib
        isElem : Eq a => a -> List a -> Bool
        isElem _ [] = False
        isElem x (y :: ys) =
            if x == y
                then True
                else isElem x ys

        alienElem : Eq a => (checked : List a) -> (checker : List a) -> Bool
        alienElem [] _ = True -- not alien in first list
        alienElem _ [] = False -- find alien in first list
        alienElem (x :: xs) ys =
            if isElem x ys
                then alienElem xs ys
                else False

    multiperm : List (List Nat) -> List Color -> List Color
    multiperm [] xs = xs
    multiperm (i :: is) xs = multiperm is (perm i xs) where

        perm : List Nat -> List Color -> List Color
        perm is xs = new 0 xs . sort . get 0 xs . sort $ zip is (shift is) where

            new : (index : Nat) -> (elems : List Color) -> (saved : List (Nat, Color)) -> List Color
            new _ elems [] = elems
            new n (elem :: elems) saved@((i, savedElem) :: saveds) =
                if n == i
                    then savedElem :: new (n+1) elems saveds
                    else elem :: new (n+1) elems saved
            new _ _ _ = []

            get : (index : Nat) -> (elems : List Color) -> (indexs : List (Nat, Nat)) -> List (Nat, Color)
            get i (elem :: elems) indexs@((indexFrom, indexDest) :: indexsFromDest) =
                if i == indexFrom
                    then (indexDest, elem) :: get (i + 1) elems indexsFromDest
                    else get (i + 1) elems indexs
            get _ _ _ = []

            -- TODO stdlib
            shift : List Nat -> List Nat
            shift [] = []
            shift (x :: xs) = xs ++ [x]

main : IO ()
main = putStrLn . show . rotate 1 $ cube2x2x2


data Input = Answer Int
           | QuitCmd

data Command : Type -> Type where
  PutStr : String -> Command ()
  GetLine : Command String
  Pure : ty -> Command ty
  Bind : Command a -> (a -> Command b) -> Command b

data ConsoleIO : Type -> Type where
  Quit : a -> ConsoleIO a
  Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b

runCommand : Command a -> IO a
runCommand (PutStr x) = putStr x
runCommand GetLine = getLine
runCommand (Pure val) = pure val
runCommand (Bind c f) = do res <- runCommand c
                           runCommand (f res)

namespace CommandDo
  (>>=) : Command a -> (a -> Command b) -> Command b
  (>>=) = Bind

namespace ConsoleDo
  (>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
  (>>=) = Do

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

mutual
  correct : Stream Int -> (score : Nat) -> (questions : Nat) -> ConsoleIO Nat
  correct nums score questions
    = do PutStr "Correct!\n"
         quiz nums (score + 1) (questions + 1)

  wrong : Stream Int -> Int -> (score : Nat) -> (questions : Nat)
    -> ConsoleIO Nat
  wrong nums ans score questions
    = do PutStr ("Wrong the answer is " ++ show ans ++ "\n")
         quiz nums score (questions + 1)

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


import Data.Vect

readVect : IO (len ** Vect len String)
readVect = do x <- getLine
              if (x == "")
                    then pure (_ ** [])
                    else do (_ ** xs) <- readVect
                            pure (_ ** x :: xs)

zipInputs : IO ()
zipInputs = do putStrLn "Enter first vector (blank line to end):"
               (len1 ** vec1) <- readVect
               putStrLn "Enter second vector (blank line to end):"
               (len2 ** vec2) <-readVect
               (case exactLength len1 vec2 of
                     Nothing => putStrLn "Vectors are of different lengths"
                     (Just vec2') => printLn (zip vec1 vec2'))


module ExampleDetectableErrors

import Data.Nat
import Data.Vect
import Data.List
import LinearTypes
import Control.Linear.LIO
import Unitary
import QStateT
import System.Random
import Injection
import Complex
import QuantumOp
import Examples

-------------------------------------- Impossible Unitaries ---------------------------------------
-- In this example, we try to apply a Hadamard gate on a non-existing wire (index 4 on a gate of size 3)

brokenH : Unitary 3
--brokenH = H 4 toffoli

-- Error: While processing right hand side of brokenH. Can't find an implementation for == (compare 4 3) LT = True.

-- In this example, we try to apply the control and the target of a CNOT on the same wire

brokenCNOT : Unitary 2
--brokenCNOT = CNOT 1 1 IdGate

-- Error: While processing right hand side of brokenCNOT. Can't find an implementation for not (== 1 1) = True.

-- In this example, we try to apply a circuit on a non existing wire (index 4 on a gate of size 3)

brokenApply1 : Unitary 3
--brokenApply1 = apply toBellBasis toffoli [1,4]

-- Error: While processing right hand side of brokenApply1. Can't find an implementation for allSmaller [1, 4] 3 && Delay (allDifferent [1, 4]) = True.

-- In this example, we try to apply a circuit twice on the same wire

brokenApply2 : Unitary 3
--brokenApply2 = apply toffoli IdGate [1,2,1]

-- Error: While processing right hand side of brokenApply2. Can't find an implementation for allSmaller [1, 2, 1] 3 && Delay (allDifferent [1, 2,1]) = True.

--------------------------------- BROKEN QUANTUM STATE OPERATIONS ---------------------------------

-- In this example, wew try to reuse a qubit that has be measured

brokenOp1 : IO (Vect 4 Bool)
{-brokenOp1  =
  run (do
      [q1,q2,q3,q4] <- newQubits {t = SimulatedOp} 4
      [b3] <- measure [q3]
      [r4,r3,r1] <- applyUnitary [q4,q3,q1] (X 0 IdGate) --trying to reuse q3
      [b1,b4,b2] <- measure [r1,r4,q2]
      pure ([b1,b2,b3,b4])
      )
      -}
-- Error: While processing right hand side of brokenOp1. q3 is not accessible in this context.

-- In this example, we try to copy a qubit

brokenOp2 : IO (Vect 5 Bool)
{-brokenOp2 =
  run (do
      [q1,q2,q3,q4] <- newQubits {t = SimulatedOp} 4
      [b3] <- measure [q3]
      [q4,q1,q5] <- applyUnitary [q4,q1,q4] (X 0 IdGate) --trying to copy q4
      [b1,b2,b5] <- measure [q1,q2,q5]
      pure [b1,b2,b3,b5,b5]
      )
      -}
--Error : While processing right hand side of brokenOp2. There are 2 uses of linear name q4.

-- In this example, we try to reuse a pointer to an old state of a qubit (the state of the qubit has been modified)

brokenOp3 : IO (Vect 4 Bool)
{-brokenOp3  =
  run (do
      [q1,q2,q3,q4] <- newQubits {t = SimulatedOp} 4
      [b3] <- measure [q3]
      [r4,r2,r1] <- applyUnitary [q4,q2,q1] (X 0 IdGate)
      [b1,b4,b2] <- measure [r1,r4,q2] --trying to reuse the name q2
      pure ([b1,b2,b3,b4])
      )
      -}
--Error: While processing right hand side of brokenOp2. q2 is not accessible in this context.


module Linear

public export
data Usage = Once | Many

public export
data Use : Usage -> (Type -> Type) -> Type -> Type where
     Pure : (1 x : a) -> Use t m a
     BindOnce : (1 act : Use Once m a) -> (1 k : (1 x : a) -> Use t m b) -> Use t m b
     BindMany : (1 act : Use Many m a) -> (1 k : (x : a) -> Use t m b) -> Use t m b

public export
contType : (Type -> Type) -> Usage -> Usage -> Type -> Type -> Type
contType m Once q a b = ((1 x : a) -> Use q m b)
contType m Many q a b = ((x : a) -> Use q m b)

public export
(>>=) : {p : _} -> (1 f : Use p m a) -> (1 k : contType m p q a b) -> Use q m b
(>>=) {p = Once} = BindOnce
(>>=) {p = Many} = BindMany

public export
pure : (1 x : a) -> Use t m a
pure = Pure

public export
One : (Type -> Type) -> Type -> Type
One = Use Once

public export
Any : (Type -> Type) -> Type -> Type
Any = Use Many


module Main

import Backprop
import Control.Algebra
import Control.Optics
import Data.List.Quantifiers
import Data.Nat
import Data.Num
import Data.String.Extra
import Data.Vect
import Debug.Trace
import Linear
import Linear.Backprop
import Linear.Math
import Linear.Random
import NN.Dense
import Utils.String

record Params where
  constructor MkParams
  dense1 : Dense 2 3 Double
  dense2 : Dense 3 1 Double

ldense1 : Simple Lens ? ?
ldense1 = lens dense1 $ \s, b => { dense1 := b } s

ldense2 : Simple Lens ? ?
ldense2 = lens dense2 $ \s, b => { dense2 := b } s

FromDouble Params where
  fromDouble x = MkParams (fromDouble x) (fromDouble x)

CanBack Params where
  zero = MkParams zero zero
  one = MkParams one one
  add (MkParams a1 a2) (MkParams b1 b2) = MkParams (add a1 b1) (add a2 b2)

Num Params where
  (+) = add
  MkParams a1 a2 * MkParams b1 b2 = MkParams (a1 * b1) (a2 * b2)
  fromInteger x = MkParams (fromInteger x) (fromInteger x)

Neg Params where
  MkParams a1 a2 - MkParams b1 b2 = MkParams (a1 - b1) (a2 - b2)
  negate (MkParams a1 a2) = MkParams (negate a1) (negate a2)

Show Params where
  show params = show_record "MkParams" [("dense1", show params.dense1), ("dense2", show params.dense2)]

model : {n : _} -> Node i Params -> Node i (T [n, 2] Double) -> Node i (T [n, 1] Double)
model p = sigmoid . apply (p ^. ldense2) . sigmoid . apply (p ^. ldense1)

loss : {a, n : _} -> Neg a => CanBack a => Floating a => (y : Node i (T [n, 1] a)) -> (y' : Node i (T [n, 1] a)) -> Node i a
loss y y' = asum $ asum $ square (y - y')

gd : {loss_t : _} -> (Neg params_t, Num params_t, CanBack params_t, CanBack loss_t, FromDouble params_t) => (loss_node : Node params_t loss_t) -> (params : params_t) -> (learning_rate : Double) -> (loss_t, params_t)
gd loss_node params alpha = let (loss, grads) = backprop loss_node params in (loss, params - fromDouble alpha * grads)

gdn : {loss_t : _} -> HasIO m => (Neg params_t, Show loss_t, Show params_t, Num params_t, CanBack params_t, CanBack loss_t, FromDouble params_t) => (iterations : Nat) -> (loss_node : Node params_t loss_t) -> (params : params_t) -> (learning_rate : Double) -> m params_t
gdn Z loss_node params alpha = pure params
gdn (S i) loss_node params alpha = do
  let (loss, params) = gd loss_node params alpha
  putStrLn $ "\{show i}: loss: \{show loss}"
  gdn i loss_node params alpha

main : IO ()
main = do
  putStrLn "begin"
  let x = the (T [_, _] Double) $ [[0, 0], [0, 1], [1, 0], [1, 1]]
  let y' = the (T [_, _] Double) $ [[0], [1], [1], [0]]
  params <- pure $ MkParams (MkDense !rand_m !rand_v) (MkDense !rand_m !rand_v)
  params <- gdn 100 (loss (model input (const x)) (const y')) params pi
  printLn "done"


-- Exercises.idr
-- Solutions for exercises of chapter 1

module Exercises

-- Check if words are palindromes

||| Checks whether the given word is a palindrome
||| The check is case-insensitive
||| @str A string to be checked
export
palindrome : (str : String) -> Bool
palindrome str = let lstr = toLower str
                     rev = reverse lstr in
                     lstr == rev

||| Checks whether the given word is a palindrome
||| The check is case-insensitive and a minimum word
||| length is required.
||| @minLen Minimum required word length for palindrome
||| @str A string to be checked
export
palindromeMinLen : (minLen : Nat) -> (str : String) -> Bool
palindromeMinLen minLen str = let wordLength = length str
                                  lstr = toLower str
                                  rev = reverse lstr in
                                  (wordLength > minLen) && (lstr == rev)

-- Count words & characters

||| Counts the number of words and characters of the given string.
||| Whitespace is ignored.
||| @str A string to be counted
export
counts : (str : String) -> (Nat, Nat)
counts str = let ww = words str
                 numWords = length ww
                 numChars = sum (map length ww) in
                 (numWords, numChars)

||| Counts the number of words and characters of the given string.
||| Whitespace is included..
||| @str A string to be counted
export
countWithSpace : (str : String) -> (Nat, Nat)
countWithSpace str = let ww = words str
                         numWords = length ww
                         numChars = length str in
                         (numWords, numChars)

-- Extract top 10 values

||| Extracts the 10 largest values from given list
||| ('top ten')
||| @l List with numeric values
export
top_ten : Ord a => (l : List a) -> List a
top_ten l = take 10 $ reverse $ sort l

-- Count strings over given length

||| Counts the number of strings wiht length
||| larger than given limit
||| @len A Nat of length limit
||| @strs A list of string
export
over_length : (len : Nat) -> (strs : List String) -> Nat
over_length len strs = length $ filter (\w => (length w) > len) strs


module Derive.TestDefs

data W : (a : Type) -> (a -> Type) -> Type where
  Sup : (x : a) -> (p x -> W a p) -> W a p


module Main

rep : (n : Nat) -> a -> List a
rep Z x = []
rep (S k) x = x :: rep k x

data RLE : List Char -> Type where
     REnd  : RLE []
     RChar : (n : Nat) -> (c : Char) -> (rs : RLE xs) ->
             RLE (rep n c ++ xs)

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

rle : (xs : List Char) -> RLE xs
rle [] = REnd
rle (x :: xs) with (rle xs)
  rle (x :: []) | REnd = RChar 1 x REnd
  rle (x :: (rep n c ++ ys)) | (RChar n c rs) with (decEq x c)
    rle (x :: (rep n x ++ ys)) | (RChar n x rs) | (Yes refl)
             = RChar (S n) x rs
    rle (x :: (rep n c ++ ys)) | (RChar n c rs) | (No f)
             = RChar 1 x (RChar n c rs)

compress : List Char -> String
compress xs with (rle xs)
  compress [] | REnd = ""
  compress (rep n c ++ ys) | (RChar n c rs)
         = show n ++ strCons c (compress ys)

compressString : String -> String
compressString xs = compress (unpack xs)

main : IO ()
main = putStrLn (compressString "foooobaaaarbaaaz")


import Data.Vect

dvec : (n : Nat) -> {default (replicate n 1) xs : Vect n Nat} -> Nat
dvec n = foldr (+) Z xs


module Main

data Identity a = Id a

runIdentity : Identity a -> a
runIdentity (Id a) = a

instance Functor Identity where
  map f (Id x) = Id (f x)

instance Applicative Identity where
  pure = Id
  (Id f) <$> (Id x) = Id (f x)

instance Monad Identity where
  (Id m) >>= f = f m

data Source : {r : Type} -> (m : Type -> Type) -> (a : Type) -> Type where
  Src : (r -> (r -> a -> m r) -> m r) -> Source {r} m a

runSource : {r : Type} -> Source {r} m a -> r -> (r -> a -> m r) -> m r
runSource (Src await) = await

Conduit : {r : Type} -> Type -> (Type -> Type) -> Type -> Type
Conduit {r} a m b = Source {r} m a -> Source {r} m b

Sink : {r : Type} -> Type -> (Type -> Type) -> Type -> Type
Sink {r} a m s = Source {r} m a -> m s

instance Functor (Source {r} m) where
    map f (Src await) = Src $ \z, yield => await z (\r => yield r . f)

foldM : Monad m => (r -> a -> m r) -> r -> List a -> m r
foldM f z []        = return z
foldM f z (x :: xs) = f z x >>= flip (foldM f) xs

source : {r : Type} -> (r -> (r -> a -> m r) -> m r) -> Source {r} m a
source = Src

sourceList : Monad m => List a -> Source m a
sourceList xs = source $ \z, yield => foldM yield z xs

mapC : Monad m => {r : Type} -> (a -> b) -> Conduit {r} a m b
mapC = map

sinkList : Monad m => Sink {r = List a} a m (List a)
sinkList (Src await) = await Prelude.List.Nil (\xs, x => return (x :: xs))

main : IO ()
main = print $ runIdentity $ sinkList $ mapC (+1) $ sourceList [1..10]


module Collections.BSTree.Set.Core

import Collections.Util.Bnd
import Collections.BSTree.Map.Core as M
import Decidable.Order.Strict

||| A verified binary search tree with erased proofs.
|||
||| The keys in the tree are constrained by min/max bounds, which make use of `Bnd` to extend the
||| tree key type with `Top` and `Bot` values. This allows for a natural way to leave bounds
||| unconstrained (by having a minimum of `Bot` or a maximum of `Top`).
|||
||| @ ord The ordering implementations used in the tree. Since these are w.r.t. a type `kTy`, the
|||       type of tree keys is defined implicitly by `ord`.
||| @ min The minimum value constraint, proving that `sto min (Mid x)` for all values `x` in the
|||       tree.
||| @ max The maximum value constraint, proving that `sto (Mid x) max` for all values `x` in the
|||       tree.
public export
BST : {0 sto : kTy -> kTy -> Type} ->
      (pre : StrictPreorder kTy sto) ->
      (tot : StrictOrdered kTy sto) ->
      (0 min,max : Bnd kTy) ->
      Type
BST pre tot min max = M.BST pre tot () min max
%name Collections.BSTree.Set.Core.BST t,u,v

||| A verified binary search tree with erased proofs.
|||
||| This is an alias for the more generic `BST` (which accepts min/max bounds for its contents).
||| The bounds are necessary for verifying the structure of a tree, but the root node of any
||| `BST` will always be unconstrained. So generally, `BST` can be considered an implementation
||| detail.
|||
||| @ ord The strict total ordering used in the tree. Since a `StrictOrdered` impl is w.r.t. a type
|||       `kTy`, the type of tree values is defined implicitly by `ord`.
public export
BSTree : {0 kTy : Type} ->
         (0 sto : kTy -> kTy -> Type) ->
         {auto pre : StrictPreorder kTy sto} ->
         {auto tot : StrictOrdered kTy sto} ->
         Type
BSTree sto {pre} {tot} = M.BST pre tot () Bot Top
%name Collections.BSTree.Set.Core.BSTree t,u,v


module Prelude.Num

import Builtin
import Prelude.Basics
import Prelude.EqOrd
import Prelude.Ops

%default total

------------------------
-- NUMERIC INTERFACES --
------------------------

%integerLit fromInteger

||| The Num interface defines basic numerical arithmetic.
public export
interface Num ty where
  constructor MkNum
  (+) : ty -> ty -> ty
  (*) : ty -> ty -> ty
  ||| Conversion from Integer.
  fromInteger : Integer -> ty

%allow_overloads fromInteger

||| The `Neg` interface defines operations on numbers which can be negative.
public export
interface Num ty => Neg ty where
  constructor MkNeg
  ||| The underlying of unary minus. `-5` desugars to `negate (fromInteger 5)`.
  negate : ty -> ty
  (-) : ty -> ty -> ty

||| Numbers for which the absolute value is defined should implement `Abs`.
public export
interface Num ty => Abs ty where
  constructor MkAbs
  ||| Absolute value.
  abs : ty -> ty

public export
interface Num ty => Fractional ty where
  constructor MkFractional
  partial
  (/) : ty -> ty -> ty
  partial
  recip : ty -> ty

  recip x = 1 / x

public export
interface Num ty => Integral ty where
  constructor MkIntegral
  partial
  div : ty -> ty -> ty
  partial
  mod : ty -> ty -> ty

----- Instances for primitives

-- Integer

%inline
public export
Num Integer where
  (+) = prim__add_Integer
  (*) = prim__mul_Integer
  fromInteger = id

%inline
public export
Neg Integer where
  negate x = prim__sub_Integer 0 x
  (-) = prim__sub_Integer

public export
Abs Integer where
  abs x = if x < 0 then -x else x

public export
Integral Integer where
  div x y
      = case y == 0 of
             False => prim__div_Integer x y
  mod x y
      = case y == 0 of
             False => prim__mod_Integer x y

-- This allows us to pick integer as a default at the end of elaboration if
-- all other possibilities fail. I don't plan to provide a nicer syntax for
-- this...
%defaulthint
%inline
public export
defaultInteger : Num Integer
defaultInteger = %search

-- Int

%inline
public export
Num Int where
  (+) = prim__add_Int
  (*) = prim__mul_Int
  fromInteger = prim__cast_IntegerInt

%inline
public export
Neg Int where
  negate x = prim__sub_Int 0 x
  (-) = prim__sub_Int

public export
Abs Int where
  abs x = if x < 0 then -x else x

public export
Integral Int where
  div x y
      = case y == 0 of
             False => prim__div_Int x y
  mod x y
      = case y == 0 of
             False => prim__mod_Int x y

-- Int8

%inline
public export
Num Int8 where
  (+) = prim__add_Int8
  (*) = prim__mul_Int8
  fromInteger = prim__cast_IntegerInt8

%inline
public export
Neg Int8 where
  negate x = prim__sub_Int8 0 x
  (-) = prim__sub_Int8

public export
Abs Int8 where
  abs x = if x < 0 then -x else x

public export
Integral Int8 where
  div x y
      = case y == 0 of
             False => prim__div_Int8 x y
  mod x y
      = case y == 0 of
             False => prim__mod_Int8 x y

-- Int16

%inline
public export
Num Int16 where
  (+) = prim__add_Int16
  (*) = prim__mul_Int16
  fromInteger = prim__cast_IntegerInt16

%inline
public export
Neg Int16 where
  negate x = prim__sub_Int16 0 x
  (-) = prim__sub_Int16

public export
Abs Int16 where
  abs x = if x < 0 then -x else x

public export
Integral Int16 where
  div x y
      = case y == 0 of
             False => prim__div_Int16 x y
  mod x y
      = case y == 0 of
             False => prim__mod_Int16 x y

-- Int32

%inline
public export
Num Int32 where
  (+) = prim__add_Int32
  (*) = prim__mul_Int32
  fromInteger = prim__cast_IntegerInt32

%inline
public export
Neg Int32 where
  negate x = prim__sub_Int32 0 x
  (-) = prim__sub_Int32

public export
Abs Int32 where
  abs x = if x < 0 then -x else x

public export
Integral Int32 where
  div x y
      = case y == 0 of
             False => prim__div_Int32 x y
  mod x y
      = case y == 0 of
             False => prim__mod_Int32 x y

-- Int64

%inline
public export
Num Int64 where
  (+) = prim__add_Int64
  (*) = prim__mul_Int64
  fromInteger = prim__cast_IntegerInt64

%inline
public export
Neg Int64 where
  negate x = prim__sub_Int64 0 x
  (-) = prim__sub_Int64

public export
Abs Int64 where
  abs x = if x < 0 then -x else x

public export
Integral Int64 where
  div x y
      = case y == 0 of
             False => prim__div_Int64 x y
  mod x y
      = case y == 0 of
             False => prim__mod_Int64 x y

-- Bits8

%inline
public export
Num Bits8 where
  (+) = prim__add_Bits8
  (*) = prim__mul_Bits8
  fromInteger = prim__cast_IntegerBits8

%inline
public export
Neg Bits8 where
  negate x = prim__sub_Bits8 0 x
  (-) = prim__sub_Bits8

public export
Abs Bits8 where
  abs x = if x < 0 then -x else x

public export
Integral Bits8 where
  div x y
      = case y == 0 of
             False => prim__div_Bits8 x y
  mod x y
      = case y == 0 of
             False => prim__mod_Bits8 x y

-- Bits16

%inline
public export
Num Bits16 where
  (+) = prim__add_Bits16
  (*) = prim__mul_Bits16
  fromInteger = prim__cast_IntegerBits16

%inline
public export
Neg Bits16 where
  negate x = prim__sub_Bits16 0 x
  (-) = prim__sub_Bits16

public export
Abs Bits16 where
  abs x = if x < 0 then -x else x

public export
Integral Bits16 where
  div x y
      = case y == 0 of
             False => prim__div_Bits16 x y
  mod x y
      = case y == 0 of
             False => prim__mod_Bits16 x y

-- Bits32

%inline
public export
Num Bits32 where
  (+) = prim__add_Bits32
  (*) = prim__mul_Bits32
  fromInteger = prim__cast_IntegerBits32

%inline
public export
Neg Bits32 where
  negate x = prim__sub_Bits32 0 x
  (-) = prim__sub_Bits32

public export
Abs Bits32 where
  abs x = if x < 0 then -x else x

public export
Integral Bits32 where
  div x y
      = case y == 0 of
             False => prim__div_Bits32 x y
  mod x y
      = case y == 0 of
             False => prim__mod_Bits32 x y

-- Bits64

%inline
public export
Num Bits64 where
  (+) = prim__add_Bits64
  (*) = prim__mul_Bits64
  fromInteger = prim__cast_IntegerBits64

%inline
public export
Neg Bits64 where
  negate x = prim__sub_Bits64 0 x
  (-) = prim__sub_Bits64

public export
Abs Bits64 where
  abs x = if x < 0 then -x else x

public export
Integral Bits64 where
  div x y
      = case y == 0 of
             False => prim__div_Bits64 x y
  mod x y
      = case y == 0 of
             False => prim__mod_Bits64 x y

-- Double

public export
Num Double where
  (+) = prim__add_Double
  (*) = prim__mul_Double
  fromInteger = prim__cast_IntegerDouble

%inline
public export
Neg Double where
  negate x = prim__negate_Double x
  (-) = prim__sub_Double

public export
Abs Double where
  abs x = if x < 0 then -x else x

public export
Fractional Double where
  (/) = prim__div_Double


module Ch03.Exercise_3_5_14

import Ch03.Arith

%default total

numValueProofIs : {t : Term} ->
                  (pf : IsNumValue t) ->
                  (nv : NumValue ** (t = nv2t nv, pf = ConvertedFrom nv))
numValueProofIs {t = (v2t (Right nv))} (ConvertedFrom nv) = (nv ** (Refl, Refl))

zeroNotSucc : {t : Term} ->
              (Zero = Succ t) -> Void
zeroNotSucc Refl impossible

succ_inj : {t1, t2 : Term} ->
           (Succ t1 = Succ t2) ->
           (t1 = t2)
succ_inj Refl = Refl

nv2t_inj : {nv1, nv2 : NumValue} ->
           (nv2t nv1 = nv2t nv2) ->
           (nv1 = nv2)
nv2t_inj {nv1=Zero} {nv2=Zero} prf = Refl
nv2t_inj {nv1=Zero} {nv2=Succ x} prf = absurd (zeroNotSucc prf)
nv2t_inj {nv1=Succ x} {nv2=Zero} prf = absurd (zeroNotSucc (sym prf))
nv2t_inj {nv1=Succ x} {nv2=Succ y} prf = cong (nv2t_inj (succ_inj prf))

numValueProofsUnique : {t : Term} ->
                       (pf1 : IsNumValue t) ->
                       (pf2 : IsNumValue t) ->
                       (pf1 = pf2)
numValueProofsUnique pf1 pf2 with (numValueProofIs pf1)
  numValueProofsUnique pf1 pf2 | (nv ** (pf_t, pf_pf)) with (numValueProofIs pf2)
    numValueProofsUnique pf1 pf2 | (nv ** (pf_t, pf_pf)) | (nv' ** (pf_t', pf_pf')) = case nv2t_inj {nv1=nv} {nv2=nv'} (trans (sym pf_t) pf_t') of
                                                                                Refl => trans pf_pf (sym pf_pf')
uniqueEval : (t : Term) ->
             (r : EvalsTo t t') ->
             (r' : EvalsTo t t'') ->
             (r = r')
uniqueEval True EIfTrue _ impossible
uniqueEval True EIfFalse _ impossible
uniqueEval True (EIf _) _ impossible
uniqueEval True (ESucc _) _ impossible
uniqueEval True EPredZero _ impossible
uniqueEval True EPredSucc _ impossible
uniqueEval True (EPred _) _ impossible
uniqueEval True EIsZeroZero _ impossible
uniqueEval True EIsZeroSucc _ impossible
uniqueEval True (EIsZero _) _ impossible
uniqueEval False EIfTrue _ impossible
uniqueEval False EIfFalse _ impossible
uniqueEval False (EIf _) _ impossible
uniqueEval False (ESucc _) _ impossible
uniqueEval False EPredZero _ impossible
uniqueEval False EPredSucc _ impossible
uniqueEval False (EPred _) _ impossible
uniqueEval False EIsZeroZero _ impossible
uniqueEval False EIsZeroSucc _ impossible
uniqueEval False (EIsZero _) _ impossible
uniqueEval (IfThenElse True y z) EIfTrue EIfTrue = Refl
uniqueEval (IfThenElse True y z) EIfTrue (EIf x) impossible
uniqueEval (IfThenElse False y z) EIfFalse EIfFalse = Refl
uniqueEval (IfThenElse False y z) EIfFalse (EIf x) impossible
uniqueEval (IfThenElse True y z) (EIf w) EIfTrue impossible
uniqueEval (IfThenElse False y z) (EIf w) EIfFalse impossible
uniqueEval (IfThenElse x y z) (EIf w) (EIf s) = case uniqueEval x w s of
                                                     Refl => Refl
uniqueEval Zero EIfTrue _ impossible
uniqueEval Zero EIfFalse _ impossible
uniqueEval Zero (EIf _) _ impossible
uniqueEval Zero (ESucc _) _ impossible
uniqueEval Zero EPredZero _ impossible
uniqueEval Zero EPredSucc _ impossible
uniqueEval Zero (EPred _) _ impossible
uniqueEval Zero EIsZeroZero _ impossible
uniqueEval Zero EIsZeroSucc _ impossible
uniqueEval Zero (EIsZero _) _ impossible
uniqueEval (Succ x) (ESucc y) (ESucc z) = case uniqueEval x y z of
                                               Refl => Refl
uniqueEval (Pred Zero) EPredZero EPredZero = Refl
uniqueEval (Pred Zero) EPredZero (EPred x) impossible
uniqueEval (Pred (Succ t')) (EPredSucc {pf=pf1}) (EPredSucc {pf=pf2}) = case numValueProofsUnique pf1 pf2 of
                                                                             Refl => Refl
uniqueEval (Pred (Succ t')) (EPredSucc {pf}) (EPred x) = absurd (valuesDontEvaluate {pf=(numValueIsValue (succNumValueIsNumValue pf))} x)
uniqueEval (Pred Zero) (EPred y) EPredZero = absurd (valuesDontEvaluate {pf=IsValue.ConvertedFrom (Right Zero)} y)
uniqueEval (Pred (Succ t')) (EPred y) (EPredSucc {pf}) = absurd (valuesDontEvaluate {pf=(numValueIsValue (succNumValueIsNumValue pf))} y)

uniqueEval (Pred x) (EPred y) (EPred z) = case uniqueEval x y z of
                                               Refl => Refl
uniqueEval (IsZero Zero) EIsZeroZero EIsZeroZero = Refl
uniqueEval (IsZero Zero) EIsZeroZero (EIsZero x) impossible
uniqueEval (IsZero (Succ nv1)) (EIsZeroSucc {pf=pf1}) (EIsZeroSucc {pf=pf2}) = case numValueProofsUnique pf1 pf2 of
                                                                                Refl => Refl
uniqueEval (IsZero (Succ nv1)) (EIsZeroSucc {pf}) (EIsZero x) = absurd (valuesDontEvaluate {pf=(numValueIsValue (succNumValueIsNumValue pf))} x)
uniqueEval (IsZero Zero) (EIsZero y) EIsZeroZero impossible
uniqueEval (IsZero (Succ nv1)) (EIsZero y) (EIsZeroSucc {pf}) = absurd (valuesDontEvaluate {pf=(numValueIsValue (succNumValueIsNumValue pf))} y)
uniqueEval (IsZero x) (EIsZero y) (EIsZero z) = case uniqueEval x y z of
                                                     Refl => Refl

||| Proof that the one-step evaluation rules of the arithmetic language are deterministic (Ex. 3.5.14).
detVal : {t,t',t'' : Term} ->
         EvalsTo t t' ->
         EvalsTo t t'' ->
         (t' = t'')
detVal {t} pf pf' = case uniqueEval t pf pf' of
                         Refl => Refl


module Control.Category

import Data.Morphisms

public export
interface Category (0 cat : obj -> obj -> Type) | cat where
  id  : cat a a
  (.) : cat b c -> cat a b -> cat a c

public export
Category Morphism where
  id                = Mor id
  -- disambiguation needed below, because unification can now get further
  -- here with Category.(.) and it's only interface resolution that fails!
  (Mor f) . (Mor g) = Mor $ Basics.(.) f g

public export
Monad m => Category (Kleislimorphism m) where
  id                        = Kleisli (pure . id)
  (Kleisli f) . (Kleisli g) = Kleisli $ \a => g a >>= f

infixr 1 >>>

public export
(>>>) : Category cat => cat a b -> cat b c -> cat a c
f >>> g = g . f


> module SequentialDecisionProblems.applications.Main

> import Data.Fin
> import Data.List
> import Data.List.Quantifiers
> import Data.So
> import Effects
> import Effect.Exception
> import Effect.StdIO

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.TabBackwardsInduction
> import SequentialDecisionProblems.Utils
> import SequentialDecisionProblems.FastStochasticDefaults
> import SequentialDecisionProblems.CoreTheoryOptDefaults
> import SequentialDecisionProblems.FullTheoryOptDefaults
> import SequentialDecisionProblems.TabBackwardsInductionOptDefaults

> import SequentialDecisionProblems.applications.FreezeOrIncrease
> import SequentialDecisionProblems.applications.GoodOrBad

> import FastSimpleProb.SimpleProb
> import FastSimpleProb.BasicOperations
> import FastSimpleProb.BasicProperties
> import FastSimpleProb.MonadicOperations
> import FastSimpleProb.MonadicProperties
> import FastSimpleProb.Measures
> import FastSimpleProb.MeasuresProperties
> import Sigma.Sigma
> import Double.Predicates
> import Double.Postulates
> import Double.Operations
> import Double.Properties
> import NonNegDouble.NonNegDouble
> import NonNegDouble.Constants
> import NonNegDouble.BasicOperations
> import NonNegDouble.Operations
> import NonNegDouble.Properties
> import NonNegDouble.Predicates
> import NonNegDouble.LTEProperties
> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Decidable.Predicates
> import Decidable.Properties
> import LocalEffect.Exception
> import LocalEffect.StdIO
> import Fin.Operations
> import List.Operations
> import Unit.Properties

> -- %default total
> %auto_implicits off

> -- %logging 5

* Introduction

We specify a first emissions game as a stochastic sequential decision
problem with a single decision maker.

* Controls

At each decision step, the decision maker has two options: freezing
emissions or increasing emissions:

> SequentialDecisionProblems.CoreTheory.Ctrl _ _ = FreezeOrIncrease

* States

At each decision step, the decision maker has to choose an option on the
bases of two data: the amount of cumulated emissions and the state of
the world. The latter can be either good or bad:

> SequentialDecisionProblems.CoreTheory.State t = (Fin (S t), GoodOrBad)

The idea is that the game starts with zero cumulated emissions and with
the world in the good state. In these conditions, the probability to
turn to the bad state is low. But if the cumulated emissions increase
beyond a critical threshold, the probability that the state of the world
turns bad increases.  If the world is the bad state, there is no chance
to come back to the good state. As for controls, it is useful to show
that |State| is finite:

* Transition function

> -- The critical threshold
> cr : Double
> cr = 0.0

> -- The probability of staying in a good world when the cumulated
> -- emissions are below the critical threshold
> p1  :  NonNegDouble
> p1  =  cast 0.65

> -- The probabilities of staying in a good world when the cumulated
> -- emissions are above the critical threshold
> p2  :  NonNegDouble
> p2  =  cast 0.1

> -- The transition function: good world, freezing emissions
> SequentialDecisionProblems.CoreTheory.nexts t (e, Good) Freeze =
>   let goodState = (weaken e, Good) in
>   let badState  = (weaken e, Bad) in
>   if (fromFin e <= cr)
>   then mkSimpleProb [(goodState, p1), (badState, one - p1)]
>   else mkSimpleProb [(goodState, p2), (badState, one - p2)]

> -- The transition function: good world, increasing emissions
> SequentialDecisionProblems.CoreTheory.nexts t (e, Good) Increase =
>   let goodState = (FS e, Good) in
>   let badState  = (FS e, Bad) in
>   if (fromFin e <= cr)  then mkSimpleProb [(goodState, p1), (badState, one - p1)]
>                         else mkSimpleProb [(goodState, p2), (badState, one - p2)]

> -- The transition function: bad world, freezing emissions
> SequentialDecisionProblems.CoreTheory.nexts t (e, Bad) Freeze =
>   let badState  = (weaken e, Bad) in mkSimpleProb [(badState, one)]

> -- The transition function: bad world, increasing emissions
> SequentialDecisionProblems.CoreTheory.nexts t (e, Bad) Increase =
>   let badState  = (FS e, Bad) in mkSimpleProb [(badState, one)]

* |Val| and |LTE|:

> SequentialDecisionProblems.CoreTheory.Val =
>   NonNegDouble.NonNegDouble

> SequentialDecisionProblems.CoreTheory.plus =
>   NonNegDouble.Operations.plus

> SequentialDecisionProblems.CoreTheory.zero =
>   fromInteger @{NumNonNegDouble} 0

> SequentialDecisionProblems.CoreTheory.LTE =
>   NonNegDouble.Predicates.LTE

> SequentialDecisionProblems.FullTheory.reflexiveLTE =
>   NonNegDouble.LTEProperties.reflexiveLTE

> SequentialDecisionProblems.FullTheory.transitiveLTE =
>   NonNegDouble.LTEProperties.transitiveLTE

> SequentialDecisionProblems.FullTheory.monotonePlusLTE =
>   NonNegDouble.LTEProperties.monotonePlusLTE

> SequentialDecisionProblems.CoreTheoryOptDefaults.totalPreorderLTE =
>   NonNegDouble.LTEProperties.totalPreorderLTE

* Reward function

The idea is that being in a good world yields one unit of benefits per
step and being in a bad world yield less benefits:

> -- Ratio of the benefits in a bad world and the benefits in a good world
> badOverGood : NonNegDouble
> badOverGood = cast 0.5

> -- Sanity check
> badOverGoodLTEone : badOverGood `NonNegDouble.Predicates.LTE` one
> badOverGoodLTEone = MkLTE Oh

Emitting greenhouse gases also brings benefits. These are a fraction of
the step benefits in a good world and freezing emissions brings less
benefits than increasing emissions:

> -- Ratio between freezing emissions benefits and step benefits (in a good world)
> freezeOverGood : NonNegDouble
> freezeOverGood = cast 0.1

> -- Ratio between increasing emissions benefits and step benefits (in a good world)
> increaseOverGood : NonNegDouble
> increaseOverGood = cast 0.3

> -- Sanity check
> freezeOverGoodLTEone : freezeOverGood `NonNegDouble.Predicates.LTE` one
> freezeOverGoodLTEone = MkLTE Oh

> -- Sanity check
> increaseOverGoodLTEone : increaseOverGood `NonNegDouble.Predicates.LTE` one
> increaseOverGoodLTEone = MkLTE Oh

> -- Sanity check
> freezeLTEincrease : freezeOverGood `NonNegDouble.Predicates.LTE` increaseOverGood
> freezeLTEincrease = MkLTE Oh

> -- Reward function:
>
> using implementation NumNonNegDouble
>
>   SequentialDecisionProblems.CoreTheory.reward _ _ Freeze   (_, Good) =
>     one                       + one * freezeOverGood
>   SequentialDecisionProblems.CoreTheory.reward _ _ Increase (_, Good) =
>     one                       + one * increaseOverGood
>   SequentialDecisionProblems.CoreTheory.reward _ _ Freeze   (_,  Bad) =
>     one * badOverGood + one * freezeOverGood
>   SequentialDecisionProblems.CoreTheory.reward _ _ Increase (_,  Bad) =
>     one * badOverGood + one * increaseOverGood

* Completing the problem specification

To be able to apply the verified, generic backwards induction algorithm
of |CoreTheory| to compute optimal policies for our problem, we have to
explain how the decision maker accounts for uncertainties on rewards
induced by uncertainties in the transition function. We first assume
that the decision maker measures uncertain rewards by their expected
value:

> SequentialDecisionProblems.CoreTheory.meas = expectedValue
> SequentialDecisionProblems.FullTheory.measMon = monotoneExpectedValue

Further on, we have to implement the notions of viability and
reachability. We start by positing that all states are viable for any
number of steps:

> -- Viable : (n : Nat) -> State t -> Type
> SequentialDecisionProblems.CoreTheory.Viable n x = Unit

From this definition, it trivially follows that all elements of an
arbitrary list of states are viable for an arbitrary number of steps:

> viableLemma : {t, n : Nat} -> (xs : List (State t)) -> All (Viable n) xs
> viableLemma  Nil      = Nil
> viableLemma {t} {n} (x :: xs) = () :: (viableLemma {t} {n} xs)

This fact and the (less trivial) result that simple probability
distributions are never empty, see |nonEmptyLemma| in
|MonadicProperties| in |SimpleProb|, allows us to show that the above
definition of |Viable| fulfills |viableSpec1|:

> -- viableSpec1 : (x : State t) -> Viable (S n) x -> GoodCtrl t x
> SequentialDecisionProblems.CoreTheory.viableSpec1 {t} {n} s v =
>   MkSigma Freeze (ne, av) where
>     ne : SequentialDecisionProblems.CoreTheory.NotEmpty (nexts t s Freeze)
>     ne = nonEmptyLemma (nexts t s Freeze)
>     av : SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} n) (nexts t s Freeze)
>     av = viableLemma {t = S t} (support (nexts t s Freeze))

> SequentialDecisionProblems.Utils.finiteViable n x = finiteUnit

> SequentialDecisionProblems.Utils.decidableViable n x = decidableUnit

For reachability, we proceed in a similar way. We say that all states
are reachable

> -- Reachable : State t' -> Type
> SequentialDecisionProblems.CoreTheory.Reachable x' = Unit

which immediately implies |reachableSpec1|:

> -- reachableSpec1 : (x : State t) -> Reachable {t' = t} x -> (y : Ctrl t x) -> All (Reachable {t' = S t}) (nexts t x y)
> SequentialDecisionProblems.CoreTheory.reachableSpec1 {t} x r y = all (nexts t x y) where
>   all : (sp : SimpleProb  (State (S t))) -> SequentialDecisionProblems.CoreTheory.All (Reachable {t' = S t}) sp
>   all sp = all' (support sp) where
>     all' : (xs : List (State (S t))) -> Data.List.Quantifiers.All (Reachable {t' = S t}) xs
>     all' Nil = Nil
>     all' (x :: xs) = () :: (all' xs)

and decidability of |Reachable|:

> SequentialDecisionProblems.TabBackwardsInduction.decidableReachable x = decidableUnit

Finally, we have to show that controls are finite

> -- finiteCtrl : {t : Nat} -> (x : State t) -> Finite (Ctrl t x)
> SequentialDecisionProblems.Utils.finiteCtrl _ = finiteFreezeOrIncrease

and, in order to use the fast, tail-recursive tabulated version of
backwards induction, that states are finite:

> SequentialDecisionProblems.TabBackwardsInduction.finiteState t =
>   finitePair (finiteFin) (finiteGoodOrBad)

* Optimal policies, optimal decisions, ...

We can now apply the results of our |CoreTheory| and of the |FullTheory|
to compute verified optimal policies, possible state-control sequences,
etc. To this end, we need to be able to show the outcome of the decision
process. This means implemeting functions to print states and controls:

> -- showState : {t : Nat} -> State t -> String
> SequentialDecisionProblems.Utils.showState {t} (e, Good) =
>   "(" ++ show (finToNat e) ++ ",Good)"
> SequentialDecisionProblems.Utils.showState {t} (e, Bad) =
>   "(" ++ show (finToNat e) ++ ",Bad)"

> -- showControl : {t : Nat} -> {x : State t} -> Ctrl t x -> String
> SequentialDecisionProblems.Utils.showCtrl {t} {x} Freeze = "Freeze"
> SequentialDecisionProblems.Utils.showCtrl {t} {x} Increase = "Increase"

>
> using implementation ShowNonNegDouble
>
>   computation : { [STDIO] } Eff ()
>   computation =
>     do putStr ("enter number of steps:\n")
>        nSteps <- getNat
>        case (decidableViable {t = Z} nSteps (FZ, Good)) of
>          (Yes v) => do putStrLn ("computing optimal policies ...")
>                        -- ps   <- pure (backwardsInduction Z nSteps)
>                        ps   <- pure (tabTailRecursiveBackwardsInduction Z nSteps)
>                        putStrLn ("computing optimal controls ...")
>                        mxys <- pure (possibleStateCtrlSeqs (FZ, Good) () v ps)
>                        putStrLn "possible state-control sequences:"
>                        putStr "  "
>                        putStrLn (showlong mxys)
>                        mvs <- pure (possibleRewards' mxys)
>                        putStrLn "possible rewards:"
>                        putStr "  "
>                        putStrLn (show mvs)
>                        putStrLn ("done!")
>          (No _)  => putStrLn ("initial state non viable for " ++ cast {from = Int} (cast nSteps) ++ " steps")

> main : IO ()
> main = run computation

> {-

> ---}

-- Local Variables:
-- idris-packages: ("effects")
-- End:


> module NonNegDouble.Properties

> import Data.So
> import Syntax.PreorderReasoning

> import Double.Predicates
> import Double.Postulates
> import Double.Properties
> import NonNegDouble.NonNegDouble
> import NonNegDouble.Constants
> import NonNegDouble.BasicOperations
> import NonNegDouble.Operations
> import List.Operations
> import Subset.Properties
> import Pairs.Operations
> import Unique.Predicates

> %default total
> %access public export

* Positivity of constants

> ||| zero is not positive
> notPositiveZero : Not (Positive (toDouble NonNegDouble.Constants.zero))
> notPositiveZero = s3 where
>   s0 : toDouble (Element 0.0 (MkLTE Oh)) = 0.0
>   s0 = Refl
>   s1 : Element 0.0 (MkLTE Oh) = NonNegDouble.Constants.zero
>   s1 = Refl
>   s2 : toDouble NonNegDouble.Constants.zero = 0.0
>   s2 = replace {P = \ X => toDouble X = 0.0} s1 s0
>   s3 : Not (Positive (toDouble NonNegDouble.Constants.zero))
>   s3 = replace {P = \ X => Not (Positive X)} (sym s2) Double.Properties.notPositiveZero

> ||| one is positive
> positiveOne : Positive (toDouble NonNegDouble.Constants.one)
> positiveOne = MkLT Oh

* Implementations:

> ||| NonNegDouble is an implementation of Show
> -- implementation [ShowNonNegDouble] Show NonNegDouble where
> implementation [ShowNonNegDouble] Show NonNegDouble where
>   show = show . toDouble

> ||| NonNegDouble is an implementation of Num
> implementation [NumNonNegDouble] Num NonNegDouble where
>   (+) = plus
>   (*) = mult
>   fromInteger = fromNat . fromIntegerNat

> using implementation NumNonNegDouble
>   ||| NonNegDouble is an implementation of Fractional
>   implementation [FractionalNonNegDouble] Fractional NonNegDouble where
>     (/) = div

> ||| NonNegDouble is an implementation of Eq
> implementation [EqNonNegDouble] Eq NonNegDouble where
>   (==) x y = (toDouble x) == (toDouble y)

> using implementation NumNonNegDouble
>   using implementation EqNonNegDouble
>     ||| NonNegDouble is an implementation of Ord
>     implementation [OrdNonNegDouble] Ord NonNegDouble where
>       compare x y = compare (toDouble x) (toDouble y)

* Properties of |toDouble|:

> using implementation NumNonNegDouble
>   |||
>   toDoublePlusLemma : (x : NonNegDouble) -> (y : NonNegDouble) -> toDouble (x + y) = (toDouble x) + (toDouble y)
>   toDoublePlusLemma (Element x px) (Element y py) =
>       ( toDouble ((Element x px) + (Element y py)) )
>     ={ Refl }=
>       ( toDouble (plus (Element x px) (Element y py)) )
>     ={ Refl }=
>       ( toDouble (Element (x + y) (plusPreservesNonNegativity px py)) )
>     ={ Refl }=
>       ( x + y )
>     ={ Refl }=
>       ( (toDouble (Element x px)) + (toDouble (Element y py)) )
>     QED

> using implementation NumNonNegDouble
>   |||
>   toDoubleMultLemma : (x : NonNegDouble) -> (y : NonNegDouble) -> toDouble (x * y) = (toDouble x) * (toDouble y)
>   toDoubleMultLemma (Element x px) (Element y py) =
>       ( toDouble ((Element x px) * (Element y py)) )
>     ={ Refl }=
>       ( toDouble (mult (Element x px) (Element y py)) )
>     ={ Refl }=
>       ( toDouble (Element (x * y) (multPreservesNonNegativity px py)) )
>     ={ Refl }=
>       ( x * y )
>     ={ Refl }=
>       ( (toDouble (Element x px)) * (toDouble (Element y py)) )
>     QED

> using implementation FractionalNonNegDouble
>   |||
>   toDoubleDivLemma : (x : NonNegDouble) -> (y : NonNegDouble) -> toDouble (x / y) = (toDouble x) / (toDouble y)
>   toDoubleDivLemma (Element x px) (Element y py) =
>       ( toDouble ((Element x px) / (Element y py)) )
>     ={ Refl }=
>       ( toDouble (div (Element x px) (Element y py)) )
>     ={ Refl }=
>       ( toDouble (Element (x / y) (divPreservesNonNegativity px py)) )
>     ={ Refl }=
>       ( x / y )
>     ={ Refl }=
>       ( (toDouble (Element x px)) / (toDouble (Element y py)) )
>     QED

* Properties entailed by postulates and properties of |Double|s:

> using implementation FractionalNonNegDouble
>   |||
>   divPreservesPositivity : {x, y : NonNegDouble} ->
>                            Positive (toDouble x) -> Positive (toDouble y) -> Positive (toDouble (x / y))
>   divPreservesPositivity {x} {y} pdx pdy = replace s1 s2 where
>     s1 : (toDouble x) / (toDouble y) = toDouble (x / y)
>     s1 = sym (toDoubleDivLemma x y)
>     s2 : Positive ((toDouble x) / (toDouble y))
>     s2 = Double.Postulates.divPreservesPositivity pdx pdy

> using implementation NumNonNegDouble
>   |||
>   plusAssociative : (x : NonNegDouble) -> (y : NonNegDouble) -> (z : NonNegDouble) ->
>                     x + (y + z) = (x + y) + z
>   plusAssociative (Element x px) (Element y py) (Element z pz) =
>       ( Element x px + ((Element y py) + (Element z pz)) )
>     ={ Refl }=
>       ( Element x px + Element (y + z) (plusPreservesNonNegativity py pz) )
>     ={ Refl }=
>       ( Element (x + (y + z)) (plusPreservesNonNegativity px (plusPreservesNonNegativity py pz)) )
>     ={ subsetEqLemma1 (Element (x + (y + z)) (plusPreservesNonNegativity px (plusPreservesNonNegativity py pz)))
>                       (Element ((x + y) + z) (plusPreservesNonNegativity (plusPreservesNonNegativity px py) pz))
>                       (plusAssociative x y z) uniqueLTE }=
>       ( Element ((x + y) + z) (plusPreservesNonNegativity (plusPreservesNonNegativity px py) pz) )
>     ={ Refl }=
>       ( Element (x + y) (plusPreservesNonNegativity px py) + Element z pz )
>     ={ Refl }=
>       ( ((Element x px) + (Element y py)) + Element z pz )
>     QED

> {-

> ---}


module Algebra.Monoid

import Data.List

%default total

||| This interface is a witness that for a
||| type `a` the axioms of a monoid hold: `(<+>)` is associative
||| with `neutral` being the neutral element.
public export
interface Monoid a => LMonoid a where
  0 appendAssociative : {x,y,z : a} -> x <+> (y <+> z) === (x <+> y) <+> z

  0 appendLeftNeutral : {x : a} -> Prelude.neutral <+> x === x

  0 appendRightNeutral : {x : a} -> x <+> Prelude.neutral === x

export
LMonoid (List a) where
  appendAssociative = Data.List.appendAssociative _ _ _
  appendRightNeutral = appendNilRightNeutral _
  appendLeftNeutral = Refl

unsafeRefl : a === b
unsafeRefl = believe_me (Refl {x = a})

export
LMonoid String where
  appendAssociative = unsafeRefl
  appendRightNeutral = unsafeRefl
  appendLeftNeutral = unsafeRefl

||| This interface is a witness that for a
||| type `a` the axioms of a commutative monoid hold:
||| `(<+>)` is commutative.
public export
interface LMonoid a => CommutativeMonoid a where
  0 appendCommutative : {x,y : a} -> x <+> y === y <+> x


module Average

export
average : String -> Double
average str = let numWords = wordCount str
                  totalLength = sum (allLengths (words str)) in
			      cast totalLength / cast numWords
	where
		wordCount: String -> Nat
		wordCount str = length (words str)

		allLengths : List String -> List Nat
		allLengths strs = map length strs

add : Int -> Int -> Int
add x y = x + y

identity: ty -> ty
identity x = x

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

twice : (a -> a) -> a -> a
twice f x = f (f x)

Shape : Type
rotate : Shape -> Shape

quadruple : Num a => a -> a
quadruple = twice double

turn_around : Shape -> Shape
turn_around = twice rotate

longer : String -> String -> String
longer word1 word2
	= let len1 = length word1
	      len2 = length word2 in
              if len1 > len2 then word1 else word2

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

wordCount : String -> Nat
wordCount str = length (words str)

allLengths : List String -> List Nat
allLengths strs = map length strs

-- single line comment

{-
Multiple
Line
Comment
-}


module Prob

import Marginalization
import Semiring
import HetVect

%default total
%access public export

-- TODO: convert to haskell, parallel, prove

mutual
  ||| Probability monad which keeps a list of the variables it contains
  ||| Prob s xs a = probability of `a`, given `xs`. `s` is the unit
  data Prob : Type -> Type -> Type where
    ||| change to (forall s. Semiring s => (a -> s) -> s) in order to avoid enum,
    ||| bounded constraints (maybe).
    Dst : (a -> s) -> Prob s a
    Bnd
      : {xs : List Type}
      -> {auto finite : AllFinite xs}
      -> MultiProb s xs
      -> (Vect xs -> Prob s b)
      -> Prob s b

  data MultiProb : Type -> List Type -> Type where
    Nil  : MultiProb s []
    (::) : {x : Type} -> Prob s x -> MultiProb s xs -> MultiProb s (x :: xs)

getProb : Semiring s => Prob s a -> a -> s
getProb (Dst f) = f
getProb (Bnd {xs} ps f) = \y => margVec (\ws => allMessages ws * getProb (f ws) y) where

  funcs : Semiring s => {ys : List Type} -> MultiProb s ys -> s -> Vect ys -> s
  funcs [] = \n, _ => n
  funcs (p::ps) =
    let m  = getProb p
        ms = funcs ps
    in \n, (v::vs) => ms (n * m v) vs -- change to not tail-recursive to make parallel

  allMessages : Vect xs -> s
  allMessages = funcs ps one

getProbPar : Semiring s => Prob s a -> a -> s
getProbPar (Dst f) = f
getProbPar (Bnd {xs} ps f) = \y => margVec (\ws => allMessages ws * getProb (f ws) y) where

  funcs : Semiring s => {ys : List Type} -> MultiProb s ys -> Vect ys -> s
  funcs [] = \_ => one
  funcs (p::ps) = \(v::vs) =>
    let m  = getProbPar p v -- Evaluate these in parallel (only currently possible in Haskell)
        ms = funcs ps vs
    in ms * m

  allMessages : Vect xs -> s
  allMessages = funcs ps


-- ----------------------------------------------------------- [ Chapter11.idr ]
-- Module      : Exercises.Chapter11
-- Description : Solutions to the Chapter 11 exercises in Edwin Brady's
--               book, "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Exercises.Chapter11

import Data.Primitives.Views
import Test

%access  export
%default total

-- ------------------------------------------------------- [ Exercise 11.1.7.1 ]

everyOther : Stream a -> Stream a
everyOther (_ :: x :: xs) = x :: everyOther xs

-- ------------------------------------------------------ [ Exercises 11.1.7.2 ]

||| Generic infinite lists
data InfList : (elem : Type) -> Type where
  ||| An infinite list, consisting of a head element and an infinite list.
  (::) : (x : elem) -> (xs : Inf (InfList elem)) -> InfList elem

%name InfList xs, ys, zs

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

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

implementation Functor InfList where
  map f (x :: xs) = f x :: map f xs -- FIXME: Delay is implicit, right?

-- ------------------------------------------------------- [ Exercise 11.1.7.3 ]

randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
                  (seed' `shiftR` 2) :: randoms seed'

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

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

||| The faces of a coin, heads or tails.
data Face = Heads | Tails

implementation Eq Face where
  (==) Heads Heads = True
  (==) Tails Tails = True
  (==) _     _     = False

syntax [test] "?" [t] ":" [e] = if test then t else e;

private
getFace : Int -> Face
getFace x with (divides x 2)
  getFace (_ + rem) | (DivBy _) = (rem == 1) ? Tails : Heads

coinFlips : (count : Nat) -> Stream Int -> List Face
coinFlips  Z     _        = []
coinFlips (S k) (x :: xs) = getFace x :: coinFlips k xs

-- ------------------------------------------------------- [ Exercise 11.1.7.4 ]

private
squareRootApprox : (number, approx : Double) -> Stream Double
squareRootApprox number approx =
  let next = (approx + (number / approx)) / 2
  in  approx :: squareRootApprox number next

-- ------------------------------------------------------- [ Exercise 11.1.7.5 ]

squareRootBound : (max : Nat) -> (number, bound : Double)
               -> (approxs : Stream Double)
               -> Double
squareRootBound  Z    _      _     (x :: _)  = x
squareRootBound (S k) number bound (x :: xs) =
  if bound > abs (x * x)
    then x
    else squareRootBound k number bound xs

squareRoot : (number : Double) -> Double
squareRoot number = squareRootBound 100 number 0.00000000001
                      (squareRootApprox number number)

-- ------------------------------------------------------------------- [ InfIO ]

namespace InfIO
  data InfIO : Type where
       Do    : IO a -> (a -> Inf InfIO) -> InfIO

  (>>=) : IO a -> (a -> Inf InfIO) -> InfIO
  (>>=) = Do

data Fuel = Dry | More (Lazy Fuel)

tank : Nat -> Fuel
tank  Z    = Dry
tank (S k) = More (tank k)

partial
forever : Fuel
forever = More forever

run : Fuel -> InfIO -> IO ()
run  Dry         _       = putStrLn "Out of fuel"
run (More fuel) (Do c f) = do res <- c
                              run fuel (f res)

-- --------------------------------------------------------- [ Exercise 11.2.7 ]

totalREPL : (prompt : String) -> (action : String -> String) -> InfIO
totalREPL prompt action
  = do putStr prompt
       input <- getLine
       putStr (action input)
       totalREPL prompt action

-- ------------------------------------------ [ 11.3.2 Domain Specific Comands ]

data Command  : Type -> Type where
     PutStr   : String -> Command ()
     PutStrLn : String -> Command ()
     GetLine  : Command String

     Pure     : ty -> Command ty
     Bind     : Command a -> (a -> Command b) -> Command b

-- ------------------------------------------------------- [ Exercise 11.3.4.2 ]
     ReadFile  : (filepath : String) -> Command (Either FileError String)
     WriteFile : (filepath, contents : String) -> Command (Either FileError ())

namespace CommandDo
  (>>=) : Command a -> (a -> Command b) -> Command b
  (>>=) = Bind

runCommand : Command a -> IO a
runCommand (PutStr   str) = putStr str
runCommand (PutStrLn str) = putStrLn str
runCommand  GetLine       = getLine
runCommand (Pure val)     = pure val
runCommand (Bind c f)     = runCommand c >>= runCommand . f
runCommand (ReadFile  filepath)          = readFile filepath
runCommand (WriteFile filepath contents) = writeFile filepath contents

data ConsoleIO : Type -> Type where
     Quit      : a -> ConsoleIO a
     Do        : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b

namespace ConsoleDo
  (>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
  (>>=) = Do

  run : Fuel -> ConsoleIO a -> IO (Maybe a)
  run       fuel  (Quit val) = do pure (Just val)
  run (More fuel) (Do c f)   = do res <- runCommand c
                                  run fuel (f res)
  run  Dry         p         = pure Nothing

  run_ : Fuel -> ConsoleIO a -> IO ()
  run_       fuel  (Quit val) = pure ()
  run_ (More fuel) (Do c f)   = do res <- runCommand c
                                   run_ fuel (f res)
  run_  Dry         p         = pure ()

  partial
  runForever : ConsoleIO a -> IO (Maybe a)
  runForever = run forever

  partial
  runForever_ : ConsoleIO a -> IO ()
  runForever_ = run_ forever

-- ---------------------------------------------- [ 11.3.3 Sequencing Commands ]

data Input = Answer Int
           | QuitCmd

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

-- ------------------------------------------------------- [ Exercise 11.3.4.1 ]

record QuizState where
  constructor MkQuizState
  score, attempts : Nat

implementation Show QuizState where
  show (MkQuizState score attempts)
    = show score ++ " / " ++ show attempts

private
arithInputs : (seed : Int) -> Stream Int
arithInputs seed = map bound (randoms seed)
  where
    bound : Int -> Int
    bound num with (divides num 12)
      bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1

mutual
  correct : Stream Int -> QuizState -> ConsoleIO QuizState
  correct nums state
    = do PutStrLn "Correct!"
         quiz nums (record { score $= (+ 1) } state)

  wrong : Stream Int -> Int -> QuizState -> ConsoleIO QuizState
  wrong nums answer state
    = do PutStrLn $ "Wrong, the answer is: " ++ show answer
         quiz nums state

  quiz : Stream Int -> QuizState -> ConsoleIO QuizState
  quiz (num1 :: num2 :: nums) state
    = do PutStrLn $ "Score so far: " ++ show state
         input <- readInput $ show num1 ++ " * " ++ show num2 ++ "? "
         case input of
              Answer answer =>
                let newState = record { attempts $= (+ 1) } state
                    correctAnswer = num1 * num2 in
                if answer == correctAnswer
                   then correct nums newState
                   else wrong nums correctAnswer newState
              QuitCmd =>
                Quit state

-- ------------------------------------------------------- [ Exercise 11.3.4.3 ]

mutual
  ||| Read the contents of a file and print it to stdout with a trailing
  ||| newline. Print an error message if filename is not a normal file.
  cat : (filename : String) -> ConsoleIO ()
  cat filename
    = do Right contents <- ReadFile filename
           | Left err => do PutStrLn (show err)
                            shell
         PutStrLn contents
         shell

  ||| Read the contents of a source file and write it to a destination file.
  ||| Print an error message if anything goes wrong.
  ||| @ source a source filepath, must be a normal file
  ||| @ destination a destination filepath, must be writable
  copy : (source, destination : String) -> ConsoleIO ()
  copy source destination
    = do Right contents <- ReadFile source
           | Left err => do PutStrLn (show err)
                            shell
         Right () <- WriteFile destination contents
           | Left err => do PutStrLn (show err)
                            shell
         shell

  ||| Print a warning about an invalid command.
  ||| @ command a string that represents an invalid command
  invalidCommand : (command : String) -> ConsoleIO ()
  invalidCommand command
    = do PutStrLn ("Invalid command: " ++ command)
         shell

  ||| Quit the shell.
  exit : ConsoleIO ()
  exit = Quit ()

  ||| Run a limited, interactive shell.
  ||| Supported commands:
  |||   - cat [filename]
  |||   - copy [source] [destination]
  |||   - exit
  shell : ConsoleIO ()
  shell = do PutStr "> "
             input <- GetLine
             case words input of
                  ["exit"] => exit
                  ["cat", filepath] => cat filepath
                  ["copy", source, destination] => copy source destination
                  _ => invalidCommand input

-- ------------------------------------------------------------------- [ Tests ]

testEveryOther : IO ()
testEveryOther = assertEq [2,4..20] $ take 10 (everyOther [1..])

testInfListFunctor : IO ()
testInfListFunctor = assertEq [2,4..20] $ getPrefix 10 (map (*2) (countFrom 1))

testCoinFlips : IO ()
testCoinFlips = assertEq [Tails,Heads,Tails,Tails,Heads,Tails] $
                         coinFlips 6 (randoms 12345)

testSquareRootApprox1 : IO ()
testSquareRootApprox1 = assertEq [10.0,5.5,3.659090909090909] $
                                 take 3 (squareRootApprox 10 10)

testSquareRootApprox2 : IO ()
testSquareRootApprox2 = assertEq [25.0,14.5,10.698275862068964] $
                                 take 3 (squareRootApprox 100 25)

testSquareRoot1 : IO ()
testSquareRoot1 = assertEq 2.449489742783178 (squareRoot 6)

testSquareRoot2 : IO ()
testSquareRoot2 = assertEq 50.0 (squareRoot 2500)

testSquareRoot3 : IO ()
testSquareRoot3 = assertEq 50.009999000199954 (squareRoot 2501)

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


module Crypto.Hash.MD5

import Crypto.Hash.Interfaces
import Data.Bits
import Data.DPair
import Data.Fin
import Data.Fin.Extra
import Data.List
import Data.Nat
import Data.Nat.Factor
import Data.Vect
import Utils.Misc
import Utils.Bytes
import Data.Stream
import Crypto.Hash.MerkleDamgard

export
data MD5 : Type where
  MkMD5 : MerkleDamgard 4 64 Bits32 -> MD5

k_table : Vect 64 Bits32
k_table =
  [ 0xd76aa478, 0xe8c7b756, 0x242070db, 0xc1bdceee
  , 0xf57c0faf, 0x4787c62a, 0xa8304613, 0xfd469501
  , 0x698098d8, 0x8b44f7af, 0xffff5bb1, 0x895cd7be
  , 0x6b901122, 0xfd987193, 0xa679438e, 0x49b40821
  , 0xf61e2562, 0xc040b340, 0x265e5a51, 0xe9b6c7aa
  , 0xd62f105d, 0x02441453, 0xd8a1e681, 0xe7d3fbc8
  , 0x21e1cde6, 0xc33707d6, 0xf4d50d87, 0x455a14ed
  , 0xa9e3e905, 0xfcefa3f8, 0x676f02d9, 0x8d2a4c8a
  , 0xfffa3942, 0x8771f681, 0x6d9d6122, 0xfde5380c
  , 0xa4beea44, 0x4bdecfa9, 0xf6bb4b60, 0xbebfbc70
  , 0x289b7ec6, 0xeaa127fa, 0xd4ef3085, 0x04881d05
  , 0xd9d4d039, 0xe6db99e5, 0x1fa27cf8, 0xc4ac5665
  , 0xf4292244, 0x432aff97, 0xab9423a7, 0xfc93a039
  , 0x655b59c3, 0x8f0ccc92, 0xffeff47d, 0x85845dd1
  , 0x6fa87e4f, 0xfe2ce6e0, 0xa3014314, 0x4e0811a1
  , 0xf7537e82, 0xbd3af235, 0x2ad7d2bb, 0xeb86d391 ]

s_table : Vect 64 (Fin 32)
s_table =
  [ 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22
  , 5,  9, 14, 20, 5,  9, 14, 20, 5,  9, 14, 20, 5,  9, 14, 20
  , 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23
  , 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21 ]

i_table : Vect 64 (Fin 16)
i_table =
  [ 0, 1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15
  , 1, 6, 11,  0,  5, 10, 15,  4,  9, 14,  3,  8, 13,  2,  7, 12
  , 5, 8, 11, 14,  1,  4,  7, 10, 13,  0,  3,  6,  9, 12, 15,  2
  , 0, 7, 14,  5, 12,  3, 10,  1,  8, 15,  6, 13,  4, 11,  2,  9 ]

s_k_table : Vect 64 (Fin 32, Bits32)
s_k_table = zip s_table k_table

md5_init_hash_values : Vect 4 Bits32
md5_init_hash_values = [ 0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476 ]

md5_compress : (block : Vect 64 Bits8) -> (h : Vect 4 Bits32) -> Vect 4 Bits32
md5_compress block hash_values = zipWith (+) hash_values $ go (_ ** zip calc_m_g s_k_table) hash_values
  where
  calc_m_g : Vect 64 Bits32
  calc_m_g =
    let block' = map (from_le {a = Bits32} {n = 4}) $ group 16 4 block
    in map (\i => index i block') i_table
  loop : Bits32 -> Bits32 -> Bits32 -> Fin 32 -> Bits32 -> Bits32 -> Bits32 -> Bits32 -> Vect 4 Bits32
  loop f m_g k_i s_i a b c d =
    let f = f + a + k_i + m_g
        a = d
        d = c
        c = b
        b = b + rotl s_i f
    in [a, b, c, d]
  go : (n ** Vect n (Bits32, Fin 32, Bits32)) -> Vect 4 Bits32 -> Vect 4 Bits32
  go (Z ** []) abcd = abcd
  go ((S n) ** ((i, s_i, k_i) :: xs)) [a, b, c, d] =
    case n `div` 16 of
      3 => go (n ** xs) $ loop (d `xor` (b .&. (c `xor` d)))    i k_i s_i a b c d
      2 => go (n ** xs) $ loop (c `xor` (d .&. (b `xor` c)))    i k_i s_i a b c d
      1 => go (n ** xs) $ loop (b `xor` c `xor` d)              i k_i s_i a b c d
      _ => go (n ** xs) $ loop (c `xor` (b .|. (complement d))) i k_i s_i a b c d

md5_update : List Bits8 -> MD5 -> MD5
md5_update input (MkMD5 s) =
  let
    Fraction _ 64 nblocks residue_nbyte prf = divMod (s.buffer_nbyte + length input) 64
    (blocks, residue) = splitAt (mult nblocks 64) (replace_vect (sym prf) (s.buffer ++ fromList input))
  in
    MkMD5 $ {buffer := residue, buffer_nbyte := _, buffer_nbyte_constraint := elemSmallerThanBound residue_nbyte }
      ( foldl (\s_, block_ => {hash_values $= md5_compress block_, npassed_blocks $= S} s_) s (group nblocks 64 blocks) )

md5_finalize : MD5 -> Vect 16 Bits8
md5_finalize (MkMD5 s) =
  concat $ map (to_le {n = 4}) $
    case pad_theorem {block_nbyte = 64} {residue_max_nbyte = 55} {length_nbyte = 8} (LTESucc LTEZero) Refl s.buffer_nbyte_constraint s.buffer (integer_to_le _ $ 8 * (cast s.npassed_blocks * 64 + cast s.buffer_nbyte)) of
      Left block => md5_compress block s.hash_values
      Right blocks => let (x1, x2) = splitAt 64 blocks in md5_compress x2 $ md5_compress x1 s.hash_values

export
Digest MD5 where
  digest_nbyte = 16
  update = md5_update
  finalize = md5_finalize

export
Hash MD5 where
  block_nbyte = 64
  initialize = MkMD5 $ mk_merkle_damgard md5_init_hash_values


||| Prime, coprime, compositie types for `Nat`
||| Extremely slow, but it totally works.
module Extra.Nat.Prime

import Data.Fin
import Data.Nat
import Data.Nat.Factor
import Data.Nat.Order
import Data.Nat.Order.Properties
import Decidable.Decidable

||| A witness of two numbers being relatively prime
public export
data Coprime : Nat -> Nat -> Type where
  MkCoprime : GCD 1 a b -> Coprime a b

||| A witness of two numbers not being relatively prime
public export
data NotCoprime : Nat -> Nat -> Type where
  MkNotCoprime0 : GCD 0 a b -> NotCoprime a b
  MkNotCoprime2 : GCD (S (S n)) a b -> NotCoprime a b

||| Coprimality of two `Nat`s
public export
data Coprimality : Nat -> Nat -> Type where
  TheyAreCoprime : Coprime a b -> Coprimality a b
  TheyArentCoprime : NotCoprime a b -> Coprimality a b

||| Calculate the coprimality of two `Nat`s
public export
coprimality : (a : Nat) -> (b : Nat) -> {auto ok: NotBothZero a b} -> Coprimality a b
coprimality a b with (Data.Nat.Factor.gcd a b)
  coprimality a b | (0 ** gcd_a_b) = TheyArentCoprime (MkNotCoprime0 gcd_a_b)
  coprimality a b | (1 ** gcd_a_b) = TheyAreCoprime (MkCoprime gcd_a_b)
  coprimality a b | ((S (S n)) ** gcd_a_b) = TheyArentCoprime (MkNotCoprime2 gcd_a_b)

||| Check are two numbers coprime to each other
public export
isCoprime : (a : Nat) -> (b : Nat) -> {auto ok: NotBothZero a b} -> Bool
isCoprime a b =
  case coprimality a b {ok = ok} of
   TheyAreCoprime _ => True
   _ => False

||| A witness of a `Nat` being a compositie number
public export
data Composite : Nat -> Type where
  MkComposite : (x : Nat) -> LTE 2 x -> LT x n -> Factor x n -> Composite n

||| A witness of a `Nat` being a prime number
public export
data Prime : Nat -> Type where
  MkPrime : ((x : Nat) -> LTE 2 x -> LT x n -> NotFactor x n) -> Prime n

||| Primality of a `Nat`
public export
data Primality : Nat -> Type where
  ItIsPrime : Prime n -> Primality n
  ItIsComposite : Composite n -> Primality n

||| This module's pseudo prime
data PseudoPrime : Nat -> Nat -> Type where
  MkPseudoPrime : LTE 2 l -> LT l n -> ((x : Nat) -> LTE l x -> LT x n -> NotFactor x n) -> PseudoPrime l n

||| Constructs a trivial pseudo prime of a `Nat`
trivial : (n : Nat) -> LTE 2 n -> PseudoPrime n (S n)
trivial 0 lte_2_n = void $ absurd lte_2_n
trivial 1 lte_2_n = void $ absurd lte_2_n
trivial (S (S n)) lte_2_n = MkPseudoPrime lte_2_n lteRefl lemma
  where
  gamma : (k : Nat) -> S k = plus (mult k 1) 1
  gamma k =
    rewrite multOneRightNeutral k in
    rewrite plusCommutative k 1 in
    Refl
  lemma : (x : Nat) -> LTE (S (S n)) x -> LTE (S x) (S (S (S n))) -> NotFactor x (S (S (S n)))
  lemma x lte lte' =
    let ccc = LTEIsAntisymmetric (S (S n)) x lte (fromLteSucc lte') in
    rewrite sym ccc in
    ProperRemExists 1 0 (gamma (S (S n)))

||| Realize that a `PseudoPrime` is an actual `Prime`
realize : PseudoPrime 2 n -> Prime n
realize (MkPseudoPrime _ _ prf) = MkPrime prf

||| Strengthen a `PseudoPrime`, used to prove some other stuff
strengthen : {l : Nat} -> LTE 2 l -> PseudoPrime (S l) n -> NotFactor l n -> PseudoPrime l n
strengthen lte (MkPseudoPrime _ lt_l_n prf) notfactor_l_n = MkPseudoPrime lte (lteSuccLeft lt_l_n) lemma
  where
  lemma : (x : Nat) -> LTE l x -> LT x n -> NotFactor x n
  lemma x lte_l_x lt_x_n = case isLTE (S l) x of
    Yes lte_Sl_x => prf x lte_Sl_x lt_x_n
    No contra => rewrite (LTEIsAntisymmetric x l (fromLteSucc $ notlteIsLT (S l) x $ notLteIsnotlte (S l) x contra) lte_l_x) in notfactor_l_n

||| The prime number 2, proved manually
public export
prime2 : Prime 2
prime2 = MkPrime lemma
  where
  lemma : (x : Nat) -> LTE 2 x -> LT x 2 -> NotFactor x 2
  lemma 0 lte_2_0 _ = void $ absurd lte_2_0
  lemma 1 lte_2_1 _ = void $ absurd lte_2_1
  lemma (S (S n)) _ lt_2_n = void $ absurd lt_2_n

||| Calculates a `Nat`'s primality
public export
primality : (n : Nat) -> LTE 2 n -> Primality n
primality 0 lte_2_0 = void $ absurd lte_2_0
primality 1 lte_2_1 = void $ absurd lte_2_1
primality 2 lte_2_2 = ItIsPrime prime2
primality n@(S (S (S k))) lte_2_n = lemma (trivial (S (S k)) (LTESucc $ LTESucc $ LTEZero))
  where
  lemma : {x : Nat} -> PseudoPrime (S (S x)) (S (S (S k))) -> Primality (S (S (S k)))
  lemma {x = 0} p = ItIsPrime (realize p)
  lemma {x = (S y)} p@(MkPseudoPrime lte_2_x lte_x_n prf) =
    case decFactor (S (S (S k))) (S (S y)) of
      ItIsFactor factor => ItIsComposite $ MkComposite (S (S y)) (lteAddRight {m = y} 2) (lteSuccLeft lte_x_n) factor
      ItIsNotFactor not_factor => lemma (strengthen (lteAddRight {m = y} 2) p not_factor)

||| Check if a `Nat` is a prime number
public export
isPrime : (n : Nat) -> {auto okay : LTE 2 n} -> Bool
isPrime 1 = void $ absurd okay
isPrime (S (S n)) = case primality (S (S n)) okay of
  ItIsPrime _ => True
  ItIsComposite _ => False


module Control.Optics.Types

import public Control.Applicative.Const
import public Control.Monad.Identity
import public Data.Contravariant
import public Data.Functor.Tagged
import public Data.Morphisms
import public Data.Profunctor
import public Data.Profunctor.Choice

public export
Simple : (Type -> Type -> Type -> Type -> Type) -> Type -> Type -> Type
Simple p s a = p s s a a

public export
Optical : (p : Type -> Type -> Type)
       -> (q : Type -> Type -> Type)
       -> (f : Type -> Type)
       -> (s : Type)
       -> (t : Type)
       -> (a : Type)
       -> (b : Type)
       -> Type
Optical p q f s t a b = p a (f b) -> q s (f t)

public export
Optic : (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type -> Type -> Type
Optic p = Optical p p

public export
LensLike : (Type -> Type) -> Type -> Type -> Type -> Type -> Type
LensLike = Optic Morphism

public export
Lens : Type -> Type -> Type -> Type -> Type
Lens s t a b = {f : Type -> Type} -> Functor f => LensLike f s t a b

public export
Setter : Type -> Type -> Type -> Type -> Type
Setter s t a b = LensLike Identity s t a b

public export
Getter : Type -> Type -> Type
Getter s a = {f : _} -> (Contravariant f, Functor f) => Simple (LensLike f) s a

public export
Getting : Type -> Type -> Type -> Type
Getting r s a = Simple (LensLike (Const r)) s a

public export
Prism : Type -> Type -> Type -> Type -> Type
Prism s t a b = {p, f : _} -> (Choice p, Applicative f) => Optic p f s t a b

public export
Review : Type -> Type -> Type -> Type -> Type
Review s t a b = {p : _} -> (Choice p) => Optic p Identity s t a b

public export
AReview : Type -> Type -> Type
AReview t b = Simple (Optic Tagged Identity) t b


module PositiveBug

data MyEmptyList : Type
data EmptyListLTE : Nat -> MyEmptyList -> Type

-- mutual
data MyEmptyList : Type where
    MyNil : MyEmptyList

data EmptyListLTE : Nat -> MyEmptyList -> Type where
    NilLTE : (x : Nat) -> EmptyListLTE x MyNil


module Control.Monad.Free

import Control.EffectAlgebra

||| Higher-order free monad.
||| Acts as a syntax generator of effectful programs.
public export
data Free : (sig : (Type -> Type) -> (Type -> Type))
         -> Type
         -> Type where
  Return : a -> Free sig a
  Op : sig (Free sig) a -> Free sig a

public export
Syntax sig => Functor (Free sig) where
  map f (Return x) = Return (f x)
  map f (Op op)    = Op (emap (map f) op)

public export
Syntax sig => Applicative (Free sig) where
  pure v = Return v

  Return v <*> prog = map v prog
  Op op    <*> prog = Op (emap (<*> prog) op)

public export
Syntax sig => Monad (Free sig) where
  Return v >>= prog = prog v
  Op op    >>= prog = Op (emap (>>= prog) op)

public export
return : a -> Free sig a
return = Return

public export
inject : Inj sub sup => sub (Free sup) a -> Free sup a
inject = Op . inj

public export
project : Prj sup sub => Free sup a -> Maybe (sub (Free sup) a)
project (Op s) = Just (prj s)
project _ = Nothing