> 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.NonDeterministicDefaults
> import SequentialDecisionProblems.CoreTheoryOptDefaults
> import SequentialDecisionProblems.FullTheoryOptDefaults
> import SequentialDecisionProblems.TabBackwardsInductionOptDefaults

> import SequentialDecisionProblems.applications.LowHigh
> import SequentialDecisionProblems.applications.AvailableUnavailable
> import SequentialDecisionProblems.applications.GoodBad

> 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 NonNegDouble.Measures
> import NonNegDouble.MeasureProperties
> 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 List.Properties
> import Unit.Properties

> -- %default total
> %auto_implicits off

> -- %logging 5

* Controls

> SequentialDecisionProblems.CoreTheory.Ctrl _ _ = LowHigh

* States

> SequentialDecisionProblems.CoreTheory.State t
> = (Fin (S t), LowHigh, AvailableUnavailable, GoodBad)

* Transition function

> -- The critical cumulated emissions threshold
> crE : Double
> crE = 0.0

> -- The critical number of decision steps
> crN : Nat
> crN = 8

> -- The transition function:
>
> -- The transition function: high emissions
>
> -- The transition function: high emissions, unavailable GHG technologies
>
> -- The transition function: high emissions, unavailable GHG technologies, good world
> SequentialDecisionProblems.CoreTheory.nexts t (e, High, Unavailable, Good) Low =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
> SequentialDecisionProblems.CoreTheory.nexts t (e, High, Unavailable, Good) High =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
>
> -- The transition function: high emissions, unavailable GHG technologies, bad world
> SequentialDecisionProblems.CoreTheory.nexts t (e, High, Unavailable, Bad) Low =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
> SequentialDecisionProblems.CoreTheory.nexts t (e, High, Unavailable, Bad) High =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
>
>
> -- The transition function: high emissions, available GHG technologies
>
> -- The transition function: high emissions, available GHG technologies, good world
> SequentialDecisionProblems.CoreTheory.nexts t (e, High, Available, Good) Low =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
> SequentialDecisionProblems.CoreTheory.nexts t (e, High, Available, Good) High =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
>
> -- The transition function: high emissions, available GHG technologies, bad world
> SequentialDecisionProblems.CoreTheory.nexts t (e, High, Available, Bad) Low =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
> SequentialDecisionProblems.CoreTheory.nexts t (e, High, Available, Bad) High =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
>
>
>
>
> -- The transition function: low emissions
>
> -- The transition function: low emissions, unavailable GHG technologies
>
> -- The transition function: low emissions, unavailable GHG technologies, good world
> SequentialDecisionProblems.CoreTheory.nexts t (e, Low, Unavailable, Good) Low =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
> SequentialDecisionProblems.CoreTheory.nexts t (e, Low, Unavailable, Good) High =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,  Unavailable, Good),
>                (    FS e, High, Unavailable, Good),
>                (weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
>
> -- The transition function: low emissions, unavailable GHG technologies, bad world
> SequentialDecisionProblems.CoreTheory.nexts t (e, Low, Unavailable, Bad) Low =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
> SequentialDecisionProblems.CoreTheory.nexts t (e, Low, Unavailable, Bad) High =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,  Unavailable,  Bad),
>                (    FS e, High, Unavailable,  Bad),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
>
>
> -- The transition function: low emissions, available GHG technologies
>
> -- The transition function: low emissions, available GHG technologies, good world
> SequentialDecisionProblems.CoreTheory.nexts t (e, Low, Available, Good) Low =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
> SequentialDecisionProblems.CoreTheory.nexts t (e, Low, Available, Good) High =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,    Available, Good),
>                (    FS e, High,   Available, Good),
>                (weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
>
> -- The transition function: low emissions, available GHG technologies, bad world
> SequentialDecisionProblems.CoreTheory.nexts t (e, Low, Available, Bad) Low =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres
> SequentialDecisionProblems.CoreTheory.nexts t (e, Low, Available, Bad) High =
>   let ttres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let tfres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ftres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   let ffres : List (State (S t))
>             = [(weaken e, Low,    Available,  Bad),
>                (    FS e, High,   Available,  Bad)] in
>   case (t <= crN) of
>     True  => case (fromFin e <= crE) of
>                True  => ttres
>                False => tfres
>     False => case (fromFin e <= crE) of
>                True  => ftres
>                False => ffres

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

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

> -- Ratio between low emissions and step benefits in good world, when
> -- effective technologies for reducing GHG emissions are unavailable
> lowOverGoodUnavailable : NonNegDouble
> lowOverGoodUnavailable = cast 0.1

> -- Ratio between low emissions and step benefits in good world, when
> -- effective technologies for reducing GHG emissions are available
> lowOverGoodAvailable : NonNegDouble
> lowOverGoodAvailable = cast 0.2

> -- Ratio between high emissions and step benefits in a good world
> highOverGood : NonNegDouble
> highOverGood = cast 0.3

> -- Sanity check
> lowOverGoodUnavailableLTEone : lowOverGoodUnavailable `NonNegDouble.Predicates.LTE` one
> lowOverGoodUnavailableLTEone = MkLTE Oh

> -- Sanity check
> lowOverGoodAvailableLTEone : lowOverGoodAvailable `NonNegDouble.Predicates.LTE` one
> lowOverGoodAvailableLTEone = MkLTE Oh

> -- Sanity check
> lowOverGoodUnavailableLTElowOverGoodAvailable : lowOverGoodUnavailable `NonNegDouble.Predicates.LTE` lowOverGoodAvailable
> lowOverGoodUnavailableLTElowOverGoodAvailable = MkLTE Oh

> -- Sanity check
> highOverGoodLTEone : highOverGood `NonNegDouble.Predicates.LTE` one
> highOverGoodLTEone = MkLTE Oh

> -- Sanity check
> lowLTEhigh : lowOverGoodAvailable `NonNegDouble.Predicates.LTE` highOverGood
> lowLTEhigh = MkLTE Oh

> -- Reward function:
> using implementation NumNonNegDouble
>
>   SequentialDecisionProblems.CoreTheory.reward _ _ _ (e, High, Unavailable, Good) =
>     one               + one * highOverGood
>   SequentialDecisionProblems.CoreTheory.reward _ _ _ (e, High, Unavailable,  Bad) =
>     one * badOverGood + one * highOverGood
>
>   SequentialDecisionProblems.CoreTheory.reward _ _ _ (e, High,   Available, Good) =
>     one               + one * highOverGood
>   SequentialDecisionProblems.CoreTheory.reward _ _ _ (e, High,   Available,  Bad) =
>     one * badOverGood + one * highOverGood
>
>   SequentialDecisionProblems.CoreTheory.reward _ _ _ (e,  Low, Unavailable, Good) =
>     one               + one * lowOverGoodUnavailable
>   SequentialDecisionProblems.CoreTheory.reward _ _ _ (e,  Low, Unavailable,  Bad) =
>     one * badOverGood + one * lowOverGoodUnavailable
>
>   SequentialDecisionProblems.CoreTheory.reward _ _ _ (e,  Low,   Available, Good) =
>     one               + one * lowOverGoodAvailable
>   SequentialDecisionProblems.CoreTheory.reward _ _ _ (e,  Low,   Available,  Bad) =
>     one * badOverGood + one * lowOverGoodAvailable

* 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 = average
> SequentialDecisionProblems.FullTheory.measMon = monotoneAverage

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)) -> SequentialDecisionProblems.CoreTheory.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 |List|, 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 Low (ne, av) where
>     ne : SequentialDecisionProblems.CoreTheory.NotEmpty (nexts t s Low)
>     ne = ?kika -- nonEmptyLemma (nexts t s Low)
>     av : SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} n) (nexts t s Low)
>     av = viableLemma {t = S t} (nexts t s Low)

> 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 : (xs : List (State (S t))) -> SequentialDecisionProblems.CoreTheory.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 _ = finiteLowHigh

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

> SequentialDecisionProblems.TabBackwardsInduction.finiteState t =
>   finiteTuple4 finiteFin finiteLowHigh finiteAvailableUnavailable finiteGoodBad

* 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, High, Unavailable, Good) =
>   "(" ++ show (finToNat e) ++ ",H,U,G)"
> SequentialDecisionProblems.Utils.showState {t} (e, High, Unavailable,  Bad) =
>   "(" ++ show (finToNat e) ++ ",H,U,B)"
> SequentialDecisionProblems.Utils.showState {t} (e, High,   Available, Good) =
>   "(" ++ show (finToNat e) ++ ",H,A,G)"
> SequentialDecisionProblems.Utils.showState {t} (e, High,   Available,  Bad) =
>   "(" ++ show (finToNat e) ++ ",H,A,B)"
> SequentialDecisionProblems.Utils.showState {t} (e,  Low, Unavailable, Good) =
>   "(" ++ show (finToNat e) ++ ",L,U,G)"
> SequentialDecisionProblems.Utils.showState {t} (e,  Low, Unavailable,  Bad) =
>   "(" ++ show (finToNat e) ++ ",L,U,B)"
> SequentialDecisionProblems.Utils.showState {t} (e,  Low,   Available, Good) =
>   "(" ++ show (finToNat e) ++ ",L,A,G)"
> SequentialDecisionProblems.Utils.showState {t} (e,  Low,   Available,  Bad) =
>   "(" ++ show (finToNat e) ++ ",L,A,B)"

> -- showControl : {t : Nat} -> {x : State t} -> Ctrl t x -> String
> SequentialDecisionProblems.Utils.showCtrl {t} {x}  Low = "L"
> SequentialDecisionProblems.Utils.showCtrl {t} {x} High = "H"

> -- ad-hoc trajectories computation
> adHocPossibleStateCtrlSeqs  :  {t, n : Nat} -> (x : State t) ->
>                                (ps : PolicySeq t n) ->
>                                M (StateCtrlSeq t n)
> adHocPossibleStateCtrlSeqs {t} {n = Z}    x  Nil        =
>   [(Nil x)]
> adHocPossibleStateCtrlSeqs {t} {n = S m}  x (p :: ps')  =
>   map ((MkSigma x y) ::) (mx' >>= f) where
>     y   :  Ctrl t x
>     y   =  ctrl (p x () ())
>     mx' :  M (State (S t))
>     mx' =  nexts t x y
>     f   :  State (S t) -> M (StateCtrlSeq (S t) m)
>     f x' = adHocPossibleStateCtrlSeqs {n = m} x' ps'

> adHocApp : {t, m, n : Nat} ->
>            StateCtrlSeq t m -> Policy (t + m) (S n) -> M (StateCtrlSeq t (S m))
> adHocApp {t} {m = Z} {n} (Nil {t} x) p = map (f . g) (nexts t x y) where
>   q : Policy t (S n)
>   q = replace {P = \ X => Policy X (S n)} (plusZeroRightNeutral t) p
>   y : Ctrl t x
>   y = ctrl (q x () ())
>   f : StateCtrlSeq (S t) Z -> StateCtrlSeq t (S Z)
>   f = ((MkSigma x y) ::)
>   g : State (S t) -> StateCtrlSeq (S t) Z
>   g x' = Nil x'
> adHocApp {t} {m = S m'} {n} (xy :: xys) p = map f (adHocApp xys q) where
>   f : StateCtrlSeq (S t) (S m') -> StateCtrlSeq t (S (S m'))
>   f = (xy ::)
>   q : Policy (S t + m') (S n)
>   q = replace {P = \ X => Policy X (S n)} (sym (plusSuccRightSucc t m')) p

> adHocExtend : {t, m, n : Nat} ->
>               M (StateCtrlSeq t m) -> PolicySeq (t + m) n -> M (StateCtrlSeq t (m + n))
> adHocExtend mxys {t} {m} {n = Z}         Nil  =
>   replace {P = \ X => M (StateCtrlSeq t X)} (sym (plusZeroRightNeutral m)) mxys
> adHocExtend mxys {t} {m} {n = S n'} (p :: ps) = s2 where
>   s1 : M (StateCtrlSeq t (plus (S m) n'))
>   s1 = adHocExtend mxys' (replace {P = \ X => PolicySeq X n'} (plusSuccRightSucc t m) ps) where
>     mxys' : M (StateCtrlSeq t (S m))
>     mxys' = mxys >>= f where
>       f : StateCtrlSeq t m ->  M (StateCtrlSeq t (S m))
>       f xys = adHocApp xys p
>   s2 : M (StateCtrlSeq t (plus m (S n')))
>   s2 = replace {P = \ X => M (StateCtrlSeq t X)} (plusSuccRightSucc m n') s1

> adHocPossibleStateCtrlSeqs1 : {t, n : Nat} -> (x : State t) ->
>                               (ps : PolicySeq t n) -> M (StateCtrlSeq t n)
> adHocPossibleStateCtrlSeqs1 {t} {n} x ps = s2 where
>
>   s1 : M (StateCtrlSeq t (Z + n))
>   s1 = adHocExtend [(Nil {t} x)] (replace {P = \ X => PolicySeq X n} (sym (plusZeroRightNeutral t)) ps)
>   s2 : M (StateCtrlSeq t n)
>   s2 = replace {P = \ X => M (StateCtrlSeq t X)} (plusZeroLeftNeutral n) s1

>
> using implementation ShowNonNegDouble
>
>   computation : { [STDIO] } Eff ()
>   computation =
>     do putStr ("enter number of steps:\n")
>        nSteps <- getNat
>        case (decidableViable {t = Z} nSteps (FZ, High, Unavailable, 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, High, Unavailable, Good) () v ps)
>                        mxys <- pure (adHocPossibleStateCtrlSeqs (FZ, High, Unavailable, Good) 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 Main

import Data.String
import Data.Vect
import System.REPL

infixr 5 .+.

data Schema = SString | SInt | (.+.) Schema Schema

SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)

record DataStore where
  constructor MkData
  schema : Schema
  size : Nat
  items : Vect size (SchemaType schema)

addToStore : (d : DataStore) -> SchemaType (schema d) -> DataStore
addToStore (MkData schema size store) newitem = MkData schema _ (addToData store)
  where
    addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)
    addToData [] = [newitem]
    addToData (x :: xs) = x :: addToData xs

data Command : Schema -> Type where
     Add : SchemaType schema -> Command schema
     Get : Integer -> Command schema
     Quit : Command schema

parseCommand : String -> String -> Maybe (Command schema)
parseCommand "add" rest = Just (Add (?parseBySchema rest))
parseCommand "get" val = case all isDigit (unpack val) of
                              False => Nothing
                              True => Just (Get (cast val))
parseCommand "quit" "" = Just Quit
parseCommand _ _ = Nothing

parse : (schema : Schema) -> (input : String) -> Maybe (Command schema)
parse schema input = case span (/= ' ') input of
                          (cmd, args) => parseCommand cmd (ltrim args)

getEntry : (pos : Integer) -> (store : DataStore) ->
           Maybe (String, DataStore)
getEntry pos store
    = let store_items = items store in
          case integerToFin pos (size store) of
               Nothing => Just ("Out of range\n", store)
               Just id => Just (?display (index id (items store)) ++ "\n", store)

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
    = case parse (schema store) input of
           Nothing => Just ("Invalid command\n", store)
           Just (Add item) =>
              Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
           Just (Get pos) => getEntry pos store
           Just Quit => Nothing

main : IO ()
main = replWith (MkData SString _ []) "Command: " processInput


-- -------------------------------------------------------------- [ Lens.idr ]
-- Description : Idris port of Control.Applicative
-- Copyright   : (c) Huw Campbell
-- --------------------------------------------------------------------- [ EOH ]
module Control.Lens.Prism
import Control.Lens.Types
import Control.Monad.Identity
import Data.Profunctor

%default total

||| Create a `Prism`
public export
prism : (b -> t) -> (s -> Either t a) -> Prism s t a b
prism bt seta = dimap seta (either pure (map bt)) . right'

public export
prism' : (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' bs sma = prism bs (\s => maybe (Left s) Right (sma s))

-- Note that in Haskell the naming convention is _Left however _ isn't allowed in Idris2
public export
left_ : Prism (Either a c) (Either b c) a b
left_ = prism Left $ either Right (Left . Right)

public export
right_ : Prism (Either c a) (Either c b) a b
right_ = prism Right $ either (Left . Left) Right

public export
just_ : Prism (Maybe a) (Maybe b) a b
just_ = prism Just $ maybe (Left Nothing) Right

public export
nothing_ : Prism' (Maybe a) ()
nothing_ = prism' (const Nothing) $ maybe (Just ()) (const Nothing)

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


import CommonTestingStuff

-------------------------------
--- Preparation for testing ---
-------------------------------

Timed (State $ SnocList String) where
  currentTime = (.millis) <$> length <$> get

CanSleep (State $ SnocList String) where
  sleepFor  _ = pure ()
  sleepTill _ = pure ()

append : MonadState (SnocList a) m => a -> m ()
append x = modify (:< x)

exec : Coop (State $ SnocList String) Unit -> SnocList String
exec = execState [<] . runCoop

-----------------------
--- Unit test cases ---
-----------------------

main : HasIO io => io ()
main = do
  putStrLn "test: do nothing"
  (exec $ pure ()) === [<]

  putStrLn "test: return time at the start"
  (exec $ currentTime >>= append . show) === [<"0"]

  putStrLn "test: return time at the start and then just a string"
  (exec $ currentTime >>= append . show >> append "test") === [<"0", "test"]

  putStrLn "test: consequent appends"
  (exec $ append "test1" *> append "test2") === [<"test1", "test2"]

  putStrLn "test: return time after some message"
  (exec $ append "before time" *> currentTime >>= append . show) === [<"before time", "1"]


module Prims

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

infixr 10 :::

-- *Prims> 1 ::: Nil
-- 1 ::: [] : MyList Integer
-- *Prims> 0 ::: 1 ::: Nil
-- 0 ::: 1 ::: [] : MyList Integer

-- Idris requires type declarations, using a single colon :
head' : MyList a -> Maybe a
head' Nil = Nothing
head' (x ::: xs) = Just x

-- *Prims> :let ls : MyList Nat; ls = 0 ::: 1 ::: Nil
-- *Prims> head' ls
-- Just 0 : Maybe Nat

-- data Nat    = Z   | S Nat        Natural numbers (zero and successor)
-- Z : Nat                          data constructors

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

x : Int
x = 123

foo : String
foo = "boo"

bar : Char
bar = 'X'

bool : Bool
bool = True


import Language.Reflection

%language ElabReflection

foo : Elab (NameType, NameType, NameType)
foo
  = do [n] <- getInfo `{ Prelude.Nat }
           | _ => fail "Can't find Nat"
       [s] <- getInfo `{ Prelude.S }
           | _ => fail "Can't find S"
       [p] <- getInfo `{ Prelude.plus }
           | _ => fail "Can't find plus"
       pure (nametype (snd n), nametype (snd s), nametype (snd p))


module Example.Pil.Gen

import Data.List

import public Example.DecEq'
import public Example.Gen
import public Example.Pil

%default total

------------------
--- Generation ---
------------------

--- Expressions ---

export
constExprGen : Gen a -> Gen (Expression ctx a)
constExprGen = map C

maybeToList : Maybe a -> List a
maybeToList (Just x) = [x]
maybeToList Nothing = []

export
varExprGen' : {a : Type} -> {ctx : Context} -> DecEq' Type => List (Expression ctx a)
varExprGen' = varExpressions {- this could be `oneOf $ map pure (fromList varExpressions)` if `Gen` could fail (contain zero) -} where
  varExpressions : List (Expression ctx a)
  varExpressions = map varExpr varsOfType where
    varExpr : (n : Name ** lk : Lookup n ctx ** reveal lk = a) -> Expression ctx a
    varExpr (n ** _ ** prf) = rewrite sym prf in V n

    varsOfType : List (n : Name ** lk : Lookup n ctx ** reveal lk = a)
    varsOfType = varsOfTypeOfCtx $ addLookups ctx
      where
        addLookups : (ctx : Context) -> List (n : Name ** ty : Type ** lk : Lookup n ctx ** reveal lk = ty)
        addLookups [] = []
        addLookups ((n, ty)::xs) = (n ** ty ** Here ty ** Refl) ::
                                   map (\(n ** ty ** lk ** lk_ty) => (n ** ty ** There lk ** lk_ty)) (addLookups xs)

        varsOfTypeOfCtx : List (n : Name ** ty : Type ** lk : Lookup n ctx ** reveal lk = ty) -> List (n : Name ** lk : Lookup n ctx ** reveal lk = a)
        varsOfTypeOfCtx [] = []
        varsOfTypeOfCtx ((n ** ty ** lk ** lk_ty)::xs) = maybeToList varX ++ varsOfTypeOfCtx xs where
          varX : Maybe (n : Name ** lk : Lookup n ctx ** reveal lk = a)
          varX = case decEq' ty a of
            (Yes ty_a) => Just (n ** lk ** trans lk_ty ty_a)
            No => Nothing

export
unaryExprGen : Gen (a -> a) -> Gen (Expression ctx a) -> Gen (Expression ctx a)
unaryExprGen gg sub = U <$> gg <*> sub

export
binaryExprGen : Gen (a -> a -> a) -> Gen (Expression ctx a) -> Gen (Expression ctx a)
binaryExprGen ggg sub = B <$> ggg <*> sub <*> sub

commonGens : {a : Type} -> {ctx : Context} -> Gen a -> DecEq' Type => (n ** Vect n $ Gen $ Expression ctx a)
commonGens g = ( _ ** [constExprGen g] ++ map pure (fromList varExprGen') )

export
exprGen : (szBound : Nat) -> {a : Type} -> Gen a -> Gen (a -> a) -> Gen (a -> a -> a) -> {ctx : Context} -> DecEq' Type => Gen (Expression ctx a)
exprGen Z g _ _ = oneOf $ snd $ commonGens g
exprGen (S n) g gg ggg = oneOf $ snd (commonGens g) ++
                               [ unaryExprGen gg (exprGen n g gg ggg)
                               , binaryExprGen ggg (exprGen n g gg ggg)
                               ]

--- Statements ---

lookupGen : (ctx : Context) -> NonEmpty ctx => Gen (n : Name ** Lookup n ctx)
lookupGen ctx = let (lks@(_::_) ** _) = mapLk ctx in
                oneOf $ map pure $ fromList lks
  where
    mapLk : (ctx : Context) -> NonEmpty ctx => (l : List (n : Name ** Lookup n ctx) ** NonEmpty l)
    mapLk [(n, ty)] = ( [(n ** Here ty)] ** IsNonEmpty )
    mapLk ((n, ty)::xs@(_::_)) = ( (n ** Here ty) :: map (\(n ** lk) => (n ** There lk)) (fst $ mapLk xs) ** IsNonEmpty )

mutual

  export
  covering
  noDeclStmtGen : (ctx : Context) ->
                  Gen Type =>
                  Gen Name =>
                  (genExpr : {a : Type} -> {ctx : Context} -> Gen (Expression ctx a)) =>
                  Gen (Statement ctx ctx)
  noDeclStmtGen ctx = oneOf
    [ pure nop
    , case ctx of
      []     => pure nop -- this is returned because `oneOf` requires `Vect`, thus all cases must have equal size.
      (_::_) => do (n ** _) <- lookupGen ctx
                   pure $ n #= !genExpr
    , do (inside_for ** init) <- stmtGen ctx
         (_ ** body) <- stmtGen inside_for
         pure $ for init !genExpr !(noDeclStmtGen inside_for) body
    , pure $ if__ !genExpr (snd !(stmtGen ctx)) (snd !(stmtGen ctx))
    , pure $ !(noDeclStmtGen ctx) *> !(noDeclStmtGen ctx)
    , pure $ block $ snd !(stmtGen ctx)
    , pure $ print !(genExpr {a=String})
    ]

  export
  covering
  stmtGen : (pre : Context) ->
            (genTy : Gen Type) =>
            (genName : Gen Name) =>
            ({a : Type} -> {ctx : Context} -> Gen (Expression ctx a)) =>
            Gen (post ** Statement pre post)
  stmtGen pre = oneOf
    [ do s <- noDeclStmtGen pre
         pure (pre ** s)
    , do ty <- genTy
         n <- genName
         pure ((n, ty)::pre ** ty. n)
    , do (mid ** l) <- stmtGen pre
         (post ** r) <- stmtGen mid
         pure (post ** l *> r)
    ]


module Lens

import Control.Category

%access public export

-- Store comonad

data Store s a = MkStore (s -> a) s

interface Functor w => Comonad (w : Type -> Type) where
  extract : w a -> a
  extend : (w a -> b) -> w a -> w b

interface Comonad w => VerifiedComonad (w : Type -> Type) where
  comonadLaw1 : (wa : w a) ->
                extend extract wa = wa
  comonadLaw2 : (f : w a -> b) ->
                (wa : w a) ->
                extract (extend f wa) = f wa
  comonadLaw3 : (f : w b -> c) ->
                (g : w a -> b) ->
                (wa : w a) ->
                extend f (extend g wa) = extend (\d => f (extend g d)) wa

Functor (Store s) where
  map f (MkStore g a) = MkStore (f . g) a

Comonad (Store s) where
  extract (MkStore f a) = f a
  extend f (MkStore g a) = MkStore (\b => f (MkStore g b)) a

-- VerifiedComonad (Store s) where
--   comonadLaw1 (MkStore f a) = ?storeIdentityProof
--   comonadLaw2 f (MkStore g a) = Refl
--   comonadLaw3 f g (MkStore h a) = Refl

-- -- TODO: This is evil.
-- -- Supposedly (jonsterling) this definition used to work without the believe_me.
-- private
-- eta : (f : a -> b) -> f = (\c => f c)
-- eta g = believe_me Refl {g}

-- storeIdentityProof = proof
--   intros
--   rewrite eta f
--   trivial

pos : Store s a -> s
pos (MkStore _ s) = s

peek : s -> Store s a -> a
peek s (MkStore f _) = f s

peeks : (s -> s) -> Store s a -> a
peeks f (MkStore g s) = g (f s)

-- Lenses

data Lens a b = MkLens (a -> Store b a)

Category Lens where
  id = MkLens (MkStore id)
  (.) (MkLens f) (MkLens g) = MkLens (\a => case g a of
    MkStore ba b => case f b of
      MkStore cb c => MkStore (Prelude.Basics.(.) ba cb) c)

lens : (a -> b) -> (b -> a -> a) -> Lens a b
lens f g = MkLens (\a => MkStore (\b => g b a) (f a))

iso : (a -> b) -> (b -> a) -> Lens a b
iso f g = MkLens (\a => MkStore g (f a))

getL : Lens a b -> a -> b
getL (MkLens f) a = pos (f a)

setL : Lens a b -> b -> a -> a
setL (MkLens f) b = peek b . f

modL : Lens a b -> (b -> b) -> a -> a
modL (MkLens f) g = peeks g . f

mergeL : Lens a c -> Lens b c -> Lens (Either a b) c
mergeL (MkLens f) (MkLens g) = MkLens $ either (\a => map Left $ f a)
                                               (\b => map Right $ g b)

infixr 0 ^$
(^$) : Lens a b -> a -> b
(^$) = getL

infixr 4 ^=
(^=) : Lens a b -> b -> a -> a
(^=) = setL

infixr 4 ^%=
(^%=) : Lens a b -> (b -> b) -> a -> a
(^%=) = modL

fstLens : Lens (a,b) a
fstLens = MkLens $ \(a,b) => MkStore (\ a' => (a', b)) a

sndLens : Lens (a,b) b
sndLens = MkLens $ \(a,b) => MkStore (\ b' => (a, b')) b

-- Partial lenses

data PLens a b = MkPLens (a -> Maybe (Store b a))

Category PLens where
  id = MkPLens (Just . MkStore id)
  (.) (MkPLens f) (MkPLens g) = MkPLens (\a => do
    MkStore wba b <- g a
    MkStore wcb c <- f b
    pure (MkStore (wba . wcb) c))

plens : (a -> Either a (Store b a)) -> PLens a b
plens f = MkPLens $ either (const Nothing) Just . f

getPL : PLens a b -> a -> Maybe b
getPL (MkPLens f) a = map pos (f a)

justPL : PLens (Maybe a) a
justPL = MkPLens (\ma => do
  a <- ma
  pure (MkStore Just a))


module Data.Time.Calendar.Days

import Generics.Derive

%default total
%language ElabReflection

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

public export
record Day where
  constructor ModifiedJulianDay
  modifiedJulianDay : Integer

%runElab derive "Day" [Generic, Meta, Eq, Ord, DecEq]

export addDays : Integer -> Day -> Day
addDays n x = { modifiedJulianDay $= (+n) } x

export diffDays : Day -> Day -> Integer
diffDays x y = x.modifiedJulianDay - y.modifiedJulianDay

-- --------------------------------------------------------------------------
-- vim: tw=80 sw=2 expandtab :


module ElabImplLambda

import Language.Reflection

%language ElabReflection

derive : {ty : Type} -> Elab ty
derive = check $
           ILam EmptyFC MW ExplicitArg (Just `{x}) `(Nat) $
             ILam EmptyFC MW AutoImplicit Nothing `(List Nat) $
               `(x + 1)

derived : Nat -> List Nat => Nat
derived = %runElab derive


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

data TypeWithFunction : Type where
    ABC  : (ty_a:Type) -> (ty_b:Type) -> (ty_a -> ty_b) -> TypeWithFunction

isInList : Elem (ABC Bool String (\c => if c then "Foo" else "Bar"))
                [(ABC Bool String (\c => if c then "Foo" else "Bar"))]
isInList = Here

isInListBad : Elem (ABC Bool String (\c => if c then "Foo" else "Bar"))
                  [(ABC Bool String (\c => if c then "Foo" else "Baz"))]
isInListBad = Here


module Idrlisp.Vec

import Data.IOArray

%default total

||| An abstract representation of idrlisp vectors.
export
data Vec a
  = NonEmpty (IOArray a) Int
  | Empty

export
length : Vec a -> Nat
length Empty = 0
length (NonEmpty _ l) = cast l

export
empty : Vec a
empty = Empty

export
new : Nat -> a -> IO (Vec a)
new size zero = do
  array <- newArray (cast size) zero
  pure $ NonEmpty array (cast size)

export
fromList : List a -> IO (Vec a)
fromList [] = pure empty
fromList (x :: xs) = do
  let l : Int = cast (length xs)
  array <- newArray (1 + l) x
  sequence_ $ zipWith (unsafeWriteArray array) [1,2..l] xs
  pure $ NonEmpty array (1 + l)

export
toList : Vec a -> IO (List a)
toList Empty = pure []
toList (NonEmpty arr l) = traverse (unsafeReadArray arr) [0,1..l-1]

export
read : Nat -> Vec a -> IO (Maybe a)
read index Empty = pure Nothing
read index (NonEmpty arr l) =
  if l <= cast index
    then pure Nothing
    else Just <$> unsafeReadArray arr (cast index)

export
write : Nat -> a -> Vec a -> IO Bool
write index value Empty = pure False
write index value (NonEmpty arr l) =
  if l <= cast index
    then pure False
    else unsafeWriteArray arr (cast index) value *> pure True

export
copy : Vec a -> Nat -> Vec a -> Nat -> Nat -> IO Bool
copy src srcStart dest destStart Z =
  pure $ srcStart <= length src && destStart <= length dest
copy (NonEmpty src srcLen) srcStart (NonEmpty dest destLen) destStart (S len) =
  if srcStart + S len <= cast srcLen && destStart + S len <= cast destLen
    then traverse readWrite [0,1..len] *> pure True
    else pure False
  where
    readWrite : Nat -> IO ()
    readWrite i =
      unsafeReadArray src (cast (i + srcStart)) >>=
      unsafeWriteArray dest (cast (i + destStart))
copy src srcStart dest destStart len = pure False


module Complex

import Control.Monad.TransitionIndexed
import Control.Monad.TransitionIndexed.Do

data Substate = Sub1 | Sub2

data ComplexState = First Substate | Second | Third

data IsFirst : ComplexState -> Type where
  ItIsFirst : IsFirst (First _)

||| Result of moving from Second to Third state
data Trans2Result = OK | Error

data ComplexCmd : (ty : Type) ->
                  ComplexState ->
                  (ty -> ComplexState) ->
                  Type where
  Init       :              ComplexCmd () (First Sub1) (const (First Sub1))
  SubTrans   :              ComplexCmd () (First Sub1) (const (First Sub2))
  Trans1Easy : IsFirst s => ComplexCmd () s (const Second)
  Trans1Hard :              ComplexCmd () (First Sub2) (const Second)
  Trans2     :              ComplexCmd Trans2Result Second (\case OK => Third; Error => Second)
  Cheat      :              ComplexCmd () Second (const Third)

  Pure : (res : ty) -> ComplexCmd ty (state_fn res) state_fn
  Bind : ComplexCmd a state1 state2_fn ->
          ((res: a) -> ComplexCmd b (state2_fn res) state3_fn) ->
          ComplexCmd b state1 state3_fn

TransitionIndexedPointed ComplexState ComplexCmd where
  pure = Pure

TransitionIndexedMonad ComplexState ComplexCmd where
  bind = Bind

easyProg : ComplexCmd () (First Sub1) (const Third)
easyProg = do
  Init
  Trans1Easy
  OK <- Trans2
    | Error => Cheat
  Pure ()

hardProg : ComplexCmd () (First Sub1) (const Third)
hardProg = do
  Init
  SubTrans
  Trans1Hard
  res <- Trans2
  case res of
       OK => Pure ()
       Error => Cheat


module ProofColDivSeqMain

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof
import Sub01Apply18x3
import Sub02Apply54x12
import Sub03Apply54x30
import Sub04Apply54x48
import Sub05Apply9x6
import Sub06Apply36x9
import Sub07Apply108x27
import Sub08Apply108x63
import Sub09Apply108x99
import Sub10Apply108x18
import Sub11Apply108x54
import Sub12Apply108x90
import Sub13Apply108x36
import Sub14Apply108x72
import Sub15Apply108x108

%default total
-- %language ElabReflection

-- 無限降下法の十分条件
unifi : (n:Nat) -> (Not . P) (S n) -> (m ** (LTE (S m) (S n), (Not . P) m))
unifi n prf with (mod3 n)
  unifi (j + j + j)         prf | ThreeZero with (parity j)
    unifi ((k+k) + (k+k) + (k+k))       prf | ThreeZero | Even = apply18x3 prf
    unifi (S (k+k) + S (k+k) + S (k+k)) prf | ThreeZero | Odd with (mod3 k)
      unifi (S ((l+l+l)+(l+l+l)) + S ((l+l+l)+(l+l+l)) + S ((l+l+l)+(l+l+l))) prf | ThreeZero | Odd | ThreeZero = apply54x12 prf
      unifi (S ((S (l+l+l))+(S (l+l+l))) + S ((S (l+l+l))+(S (l+l+l))) + S ((S (l+l+l))+(S (l+l+l)))) prf | ThreeZero | Odd | ThreeOne = apply54x30 prf
      unifi (S ((S (S (l+l+l)))+(S (S (l+l+l)))) + S ((S (S (l+l+l)))+(S (S (l+l+l)))) + S ((S (S (l+l+l)))+(S (S (l+l+l))))) prf | ThreeZero | Odd | ThreeTwo = apply54x48 prf
  unifi (S (j + j + j))     prf | ThreeOne = apply9x6 prf
  unifi (S (S (j + j + j))) prf | ThreeTwo with (parity j)
    unifi (S (S ((k+k) + (k+k) + (k+k)))) prf | ThreeTwo | Even with (parity k)
      unifi (S (S (((l+l)+(l+l)) + ((l+l)+(l+l)) + ((l+l)+(l+l))))) prf | ThreeTwo | Even | Even = apply36x9 prf
      unifi (S (S ((S (l+l)+S (l+l)) + (S (l+l)+S (l+l)) + (S (l+l)+S (l+l))))) prf | ThreeTwo | Even | Odd with (mod3 l)
        unifi (S (S ((S ((o+o+o)+(o+o+o))+S ((o+o+o)+(o+o+o))) + (S ((o+o+o)+(o+o+o))+S ((o+o+o)+(o+o+o))) + (S ((o+o+o)+(o+o+o))+S ((o+o+o)+(o+o+o)))))) prf | ThreeTwo | Even | Odd | ThreeZero = apply108x27 prf
        unifi (S (S ((S (S (o+o+o)+S (o+o+o))+S (S (o+o+o)+ S (o+o+o))) + (S (S (o+o+o)+ S (o+o+o))+S (S (o+o+o)+ S (o+o+o))) + (S (S (o+o+o)+ S (o+o+o))+S (S (o+o+o)+ S (o+o+o)))))) prf | ThreeTwo | Even | Odd | ThreeOne = apply108x63 prf
        unifi (S (S ((S (S (S (o+o+o))+S (S (o+o+o)))+S (S (S (o+o+o))+ S (S (o+o+o))) + (S (S (S (o+o+o))+ S (S (o+o+o)))+S (S (S (o+o+o))+ S (S (o+o+o)))) + (S (S (S (o+o+o))+ S (S (o+o+o)))+S (S (S (o+o+o))+ S (S (o+o+o)))))))) prf | ThreeTwo | Even | Odd | ThreeTwo = apply108x99 prf
    unifi (S (S (S (k+k) + S (k+k) + S (k+k)))) prf | ThreeTwo | Odd with (parity k)
      unifi (S (S (S ((l+l)+(l+l)) + S ((l+l)+(l+l)) + S ((l+l)+(l+l))))) prf | ThreeTwo | Odd | Even with (mod3 l)
        unifi (S (S (S (((o+o+o)+(o+o+o))+((o+o+o)+(o+o+o))) + S (((o+o+o)+(o+o+o))+((o+o+o)+(o+o+o))) + S (((o+o+o)+(o+o+o))+((o+o+o)+(o+o+o)))))) prf | ThreeTwo | Odd | Even | ThreeZero = apply108x18 prf
        unifi (S (S (S ((S (o+o+o)+S (o+o+o))+(S (o+o+o)+S (o+o+o))) + S ((S (o+o+o)+S (o+o+o))+(S (o+o+o)+S (o+o+o))) + S ((S (o+o+o)+S (o+o+o))+(S (o+o+o)+S (o+o+o)))))) prf | ThreeTwo | Odd | Even | ThreeOne = apply108x54 prf
        unifi (S (S (S ((S (S (o+o+o))+S (S (o+o+o)))+(S (S (o+o+o))+S (S (o+o+o)))) + S ((S (S (o+o+o))+S (S (o+o+o)))+(S (S (o+o+o))+S (S (o+o+o)))) + S ((S (S (o+o+o))+S (S (o+o+o)))+(S (S (o+o+o))+S (S (o+o+o))))))) prf | ThreeTwo | Odd | Even | ThreeTwo = apply108x90 prf
      unifi (S (S (S (S (l+l)+ S (l+l)) + S (S (l+l)+S (l+l)) + S (S (l+l)+S (l+l))))) prf | ThreeTwo | Odd | Odd with (mod3 l)
        unifi (S (S (S (S ((o+o+o)+(o+o+o))+ S ((o+o+o)+(o+o+o))) + S (S ((o+o+o)+(o+o+o))+S ((o+o+o)+(o+o+o))) + S (S ((o+o+o)+(o+o+o))+S ((o+o+o)+(o+o+o)))))) prf | ThreeTwo | Odd | Odd | ThreeZero = apply108x36 prf
        unifi (S (S (S (S (S (o+o+o)+S (o+o+o))+ S (S (o+o+o)+S (o+o+o))) + S (S (S (o+o+o)+S (o+o+o))+S (S (o+o+o)+S (o+o+o))) + S (S (S (o+o+o)+S (o+o+o))+S (S (o+o+o)+S (o+o+o)))))) prf | ThreeTwo | Odd | Odd | ThreeOne = apply108x72 prf
        unifi (S (S (S (S (S (S (o+o+o))+S (S (o+o+o)))+ S (S (S (o+o+o))+S (S (o+o+o)))) + S (S (S (S (o+o+o))+S (S (o+o+o)))+S (S (S (o+o+o))+S (S (o+o+o)))) + S (S (S (S (o+o+o))+S (S (o+o+o)))+S (S (S (o+o+o))+S (S (o+o+o))))))) prf | ThreeTwo | Odd | Odd | ThreeTwo = apply108x108 prf

-- 最終的な定理
divSeqLimited : (n : Nat) -> Limited $ divSeq (n+n+n)
divSeqLimited n = replace (definiP n) {P=id} $ infiniteDescent0 unifi base0
                                    -- ↑このPはreplace内部のPだよ


module BootstrappedQueue

import Queue

%default total
%access private

export
data BootstrappedQueue a =
  E | Q Int (List a) (BootstrappedQueue (Lazy (List a))) Int (List a)

mutual
  checkF : Int -> List a -> BootstrappedQueue (Lazy (List a)) -> Int -> List a
        -> BootstrappedQueue a
  checkF lenfm [] E lenr r = E
  checkF lenfm [] m lenr r = Q lenfm (Force $ head m) (tail m) lenr r
  checkF lenfm f  m lenr r = Q lenfm f m lenr r

  checkQ : Int -> List a -> BootstrappedQueue (Lazy (List a)) -> Int -> List a
        -> BootstrappedQueue a
  checkQ lenfm f m lenr r =
    if lenr <= lenfm then checkF lenfm f m lenr r
    else checkF (lenfm + lenr) f (snoc m (reverse r)) 0 []

  export
  Queue BootstrappedQueue where
    empty = E -- Incorrect in original: Q 0 [] E 0 []
    isEmpty E = True
    isEmpty _ = False

    snoc E x = Q 1 [x] E 0 [] -- Incorrect in original: q 1 [x] E 0 []
    snoc (Q lenfm f m lenr r) x = checkQ lenfm f m (lenr + 1) (x :: r)

    head E                            = idris_crash "empty queue"
    head (Q lenfm (x :: f') m lenr r) = x
    head (Q _     []        _ _    _) = assert_unreachable

    tail E                            = idris_crash "empty queue"
    tail (Q lenfm (x :: f') m lenr r) = assert_total $ checkQ (lenfm - 1) f' m lenr r
    tail (Q _     []        _ _    _) = assert_unreachable


module Data.Time.Calendar.Gregorian

import public Data.Time.Calendar.Types
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.MonthDay
import Data.Time.Calendar.Days
import Data.Time.Calendar.CalendarDiffDays

import Text.Format.Decimal

%default total

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

||| Convert to proleptic Gregorian calendar.
export toGregorian : Day -> (Year, MonthOfYear, DayOfMonth)
toGregorian date =
  let (y, yd) = toOrdinalDate date
      (m, md) = dayOfYearToMonthAndDay (isLeapYear y) yd
      in (y, m, md)

||| Convert from proleptic Gregorian calendar.
||| Invalid values will be clipped to the correct range, month first, then day.
export fromGregorian : Year -> MonthOfYear -> DayOfMonth -> Day
fromGregorian year month day =
 fromOrdinalDate year (monthAndDayToDayOfYear (isLeapYear year) month day)

||| Convert from proleptic Gregorian calendar.
||| Invalid values will return Nothing
export fromGregorianValid : Year -> MonthOfYear -> DayOfMonth -> Maybe Day
fromGregorianValid year month day =
  case monthAndDayToDayOfYearValid (isLeapYear year) month day of
    Nothing => Nothing
    Just yd => fromOrdinalDateValid year yd

||| Show in ISO 8601 format (yyyy-mm-dd)
export showGregorian : Day -> String
showGregorian x with (toGregorian x)
  showGregorian x | (y, m, d) =
    format' (zeroPad 4) y ++ "-" ++ format' (zeroPad 2) m ++ "-" ++ format' (zeroPad 2) d

public export Show Day where show = showGregorian -- orphaned instance

||| The number of days in a given month according to the proleptic Gregorian calendar.
export gregorianMonthLength : Year -> MonthOfYear -> DayOfMonth
gregorianMonthLength year = monthLength $ isLeapYear year

export rolloverMonths : (Year, Integer) -> (Year, MonthOfYear)
rolloverMonths (y, m) = (y + ((m - 1) `div` 12), cast ((m - 1) `mod` 12) + 1)

export addGregorianMonths : Integer -> Day -> (Year, MonthOfYear, DayOfMonth)
addGregorianMonths n day =
  let (y, m, d) = toGregorian day
      (y', m') = rolloverMonths (y, cast m + n)
   in (y', m', d)

||| Add months, with days past the last day of the month clipped to the last day.
||| For instance, 2005-01-30 + 1 month = 2005-02-28.
export addGregorianMonthsClip : Integer -> Day -> Day
addGregorianMonthsClip n day =
  let (y, m, d) = addGregorianMonths n day
   in fromGregorian y m d

||| Add months, with days past the last day of the month rolling over to the next month.
||| For instance, 2005-01-30 + 1 month = 2005-03-02.
export addGregorianMonthsRollOver : Integer -> Day -> Day
addGregorianMonthsRollOver n day =
  let (y, m, d) = addGregorianMonths n day
   in addDays (cast d - 1) (fromGregorian y m 1)

||| Add years, matching month and day, with Feb 29th clipped to Feb 28th if necessary.
||| For instance, 2004-02-29 + 2 years = 2006-02-28.
export addGregorianYearsClip : Integer -> Day -> Day
addGregorianYearsClip n = addGregorianMonthsClip (n * 12)

||| Add years, matching month and day, with Feb 29th rolled over to Mar 1st if necessary.
||| For instance, 2004-02-29 + 2 years = 2006-03-01.
export addGregorianYearsRollOver : Integer -> Day -> Day
addGregorianYearsRollOver n = addGregorianMonthsRollOver (n * 12)

||| Add months (clipped to last day), then add days
export addGregorianDurationClip : CalendarDiffDays -> Day -> Day
addGregorianDurationClip x day =
  addDays x.day $ addGregorianMonthsClip x.month day

||| Add months (rolling over to next month), then add days
addGregorianDurationRollOver : CalendarDiffDays -> Day -> Day
addGregorianDurationRollOver x day =
  addDays x.day $ addGregorianMonthsRollOver x.month day

||| Calendrical difference, with as many whole months as possible
diffGregorianDurationClip : Day -> Day -> CalendarDiffDays
diffGregorianDurationClip day2 day1 =
  let (y1, m1, d1) = toGregorian day1
      (y2, m2, d2) = toGregorian day2
      ym1 = y1 * 12 + cast m1
      ym2 = y2 * 12 + cast m2
      ymdiff = ym2 - ym1
      ymAllowed = if day2 >= day1 then if d2 >= d1 then ymdiff else ymdiff - 1
                  else if d2 <= d1 then ymdiff
                  else ymdiff + 1
      dayAllowed = addGregorianDurationClip (MkCalendarDiffDays ymAllowed 0) day1
   in MkCalendarDiffDays ymAllowed $ diffDays day2 dayAllowed

||| Calendrical difference, with as many whole months as possible.
||| Same as 'diffGregorianDurationClip' for positive durations.
diffGregorianDurationRollOver : Day -> Day -> CalendarDiffDays
diffGregorianDurationRollOver day2 day1 =
  let (y1, m1, d1) = toGregorian day1
      (y2, m2, d2) = toGregorian day2
      ym1 = y1 * 12 + cast m1
      ym2 = y2 * 12 + cast m2
      ymdiff = ym2 - ym1
      ymAllowed = if day2 >= day1 then if d2 >= d1 then ymdiff else ymdiff - 1
                  else if d2 <= d1 then ymdiff
                  else ymdiff + 1
      dayAllowed = addGregorianDurationRollOver (MkCalendarDiffDays ymAllowed 0) day1
   in MkCalendarDiffDays ymAllowed $ diffDays day2 dayAllowed

-- --------------------------------------------------------------------------
-- vim: tw=80 sw=2 expandtab :


module RandomAccessList

%default total
%access private

public export
interface RandomAccessList (r : Type -> Type) where
  empty : r a
  isEmpty : r a -> Bool

  cons : a -> r a -> r a
  head : r a -> a
  tail : r a -> r a

  lookup : Int -> r a -> a
  update : Int -> a -> r a -> r a


||| Testing IntMap using silly stupid tests
module Test.Patricia.Spec

import Patricia.IntMap
import Patricia.IntSet
import Specdris.Spec

----------------------------------------------------------------------------
-- Maps to test
----------------------------------------------------------------------------

initMap : Int32Map String
initMap = fromList [(1,"a"), (2,"b"), (3,"c"), (4, "d"), (4, "x")]

biggerMap : Int32Map String
biggerMap = insert 5 "e" initMap

lesserMap : Int32Map String
lesserMap = delete 10 $ delete 5 $ delete 2 biggerMap

----------------------------------------------------------------------------
-- Sets to test
----------------------------------------------------------------------------

initSet : Int32Set
initSet = fromList [1, 2, 3, 4, 4]

biggerSet : Int32Set
biggerSet = insert 5 initSet

lesserSet : Int32Set
lesserSet = delete 10 $ delete 5 $ delete 2 biggerSet

----------------------------------------------------------------------------
-- Test runner
----------------------------------------------------------------------------

export
main : IO ()
main = spec $ do
  describe "Patricia" $ do
    it "size" $ do
      size initMap   `shouldBe` 4
      size biggerMap `shouldBe` 5
      size lesserMap `shouldBe` 3
    it "lookup & insert & delete" $ do
      lookup 2 initMap   `shouldBe` Just "b"
      lookup 4 initMap   `shouldBe` Just "x"
      lookup 0 initMap   `shouldBe` Nothing
      lookup 5 biggerMap `shouldBe` Just "e"
      lookup 5 lesserMap `shouldBe` Nothing
      lookup 2 lesserMap `shouldBe` Nothing
      lookup 3 lesserMap `shouldBe` Just "c"
    it "toList" $ do
      values initMap   `shouldBe` ["a", "b", "c", "x"]
      values biggerMap `shouldBe` ["a", "b", "c", "x", "e"]
      values lesserMap `shouldBe` ["a", "c", "x"]
  describe "IntSet" $ do
    it "size" $ do
      size initSet   `shouldBe` 4
      size biggerSet `shouldBe` 5
      size lesserSet `shouldBe` 3
    it "member & insert & delete" $ do
      member 2 initSet   `shouldBe` True
      member 4 initSet   `shouldBe` True
      member 0 initSet   `shouldBe` False
      member 5 biggerSet `shouldBe` True
      member 5 lesserSet `shouldBe` False
      member 2 lesserSet `shouldBe` False
      member 3 lesserSet `shouldBe` True


module Case

listId : List a -> List a
listId xs = case xs of
  [] => []
  (x :: xs) => x :: listId xs

listRev : List a -> List a
listRev = \case
  [] => []
  (x :: xs) => listRev xs ++ [x]

listFilter2 : (p, q : a -> Bool) -> List a -> List a
listFilter2 p q xs
  = do x <- xs
       -- let pat
       let True = p x
         | False => []
       -- do pat
       True <- pure (q x)
         | False => []
       pure x


module Hedgehog.Internal.Range

import Data.Bounded
import Data.Maybe
import Data.Fin
import Decidable.Equality

import Hedgehog.Internal.Util

%hide Prelude.Range

public export
MaxSizeNat : Nat
MaxSizeNat = 100

||| A wrapper of a natural number plus an erased proof that
||| the value is within its bounds.
|||
||| Unlike the original Hedgehog, we allow values in the range [0,100]
||| treating size as a proper percentage.
public export
record Size where
  constructor MkSize
  size     : Nat
  0 sizeOk : size <= MaxSizeNat = True

public export
mkSize : (n : Nat) -> {auto 0 ok : n <= MaxSizeNat = True} -> Size
mkSize n = MkSize n ok

public export
minSize : Size
minSize = mkSize 0

public export
maxSize : Size
maxSize = mkSize MaxSizeNat

export
mkSizeMay : Nat -> Maybe Size
mkSizeMay n with (decEq (n <= MaxSizeNat) True)
  mkSizeMay n | Yes _ = Just $ mkSize n
  mkSizeMay n | No  c = Nothing

export
mkSizeOrZero : Nat -> Size
mkSizeOrZero = fromMaybe minSize . mkSizeMay

export
mkSizeOrMax : Nat -> Size
mkSizeOrMax = fromMaybe maxSize . mkSizeMay

public export
resize : (Nat -> Nat) -> Size -> Size
resize f s = mkSizeOrMax (f s.size)

--------------------------------------------------------------------------------
--          Interface Implementations
--------------------------------------------------------------------------------

export
Show Size where
  showPrec p (MkSize n _) = showPrec p n

export
Eq Size where
  (==) = (==) `on` size

export
Ord Size where
  compare = compare `on` size

export
MinBound Size where
  minBound = minSize

export
MaxBound Size where
  maxBound = maxSize

export
Num Size where
  a + b = mkSizeOrMax $ size a + size b
  a * b = mkSizeOrMax $ size a * size b
  fromInteger = mkSizeOrMax . fromInteger

public export
ToInteger Size where toInteger = toInteger . size

--------------------------------------------------------------------------------
--          Range
--------------------------------------------------------------------------------

public export
record Range a where
  constructor MkRange
  origin  : a
  bounds' : Size -> (a,a)

export
bounds : Size -> Range a -> (a,a)
bounds s r = r.bounds' s

||| Get the lower bound of a range for the given size.
export
lowerBound : Ord a => Size -> Range a -> a
lowerBound sz = uncurry min . bounds sz

||| Get the lower bound of a range for the given size.
export
upperBound : Ord a => Size -> Range a -> a
upperBound sz = uncurry max . bounds sz

export
Functor Range where
  map f (MkRange origin bounds') =
    MkRange (f origin) $
            \si => let (x,y) = bounds' si
                    in (f x, f y)

--------------------------------------------------------------------------------
--          Constant Ranges
--------------------------------------------------------------------------------

||| Construct a range which represents a constant single value.
|||
||| >>> bounds x $ singleton 5
||| (5,5)
|||
||| >>> origin $ singleton 5
||| 5
export
singleton : a -> Range a
singleton x = MkRange x $ \_ => (x, x)

||| Construct a range which is unaffected by the size parameter with a origin
||| point which may differ from the bounds.
|||
||| A range from @-10@ to @10@, with the origin at @0@:
|||
||| >>> bounds x $ constantFrom 0 (-10) 10
||| (-10,10)
|||
||| >>> origin $ constantFrom 0 (-10) 10
||| 0
|||
||| A range from @1970@ to @2100@, with the origin at @2000@:
|||
||| >>> bounds x $ constantFrom 2000 1970 2100
||| (1970,2100)
|||
||| >>> origin $ constantFrom 2000 1970 2100
||| 2000
export
constantFrom : (origin,lower,upper : a) -> Range a
constantFrom o l u = MkRange o $ \_ => (l, u)

||| Construct a range which is unaffected by the size parameter.
|||
||| A range from @0@ to @10@, with the origin at @0@:
|||
||| >>> bounds x $ constant 0 10
||| (0,10)
|||
||| >>> origin $ constant 0 10
||| 0
|||
export
constant : a -> a -> Range a
constant x y = constantFrom x x y

||| Construct a range which is unaffected by the size parameter using the full
||| range of a data type.
|||
||| A range from @-128@ to @127@, with the origin at @0@:
|||
||| >>> bounds x (constantBounded :: Range Int8)
||| (-128,127)
|||
||| >>> origin (constantBounded :: Range Int8)
||| 0
export
constantBounded : (MinBound a, MaxBound a, Num a) => Range a
constantBounded = constantFrom 0 minBound maxBound

--------------------------------------------------------------------------------
--          Linear Ranges
--------------------------------------------------------------------------------

||| Truncate a value so it stays within some range.
|||
||| >>> clamp 5 10 15
||| 10
|||
||| >>> clamp 5 10 0
||| 5
export
clamp : Ord a => (lower,upper,val : a) -> a
clamp l u v = if l > u then min l (max u v)
                       else min u (max l v)

||| Scales an integral value linearly with the size parameter.
export
scaleLinear : ToInteger a => Size -> (origin,bound : a) -> a
scaleLinear sz o0 b0 =
  let o    = toInteger o0
      b    = toInteger b0
      rng  = b - o
      diff = (rng * toInteger sz) `safeDiv` 100
   in fromInteger $ o + diff

||| Scales a fractional value linearly with the size parameter.
export
scaleLinearFrac :  (Neg a, Fractional a) => Size -> (origin,bound : a) -> a
scaleLinearFrac sz o b =
  let diff = (b - o) * (fromIntegral sz / 100)
   in o + diff

export %inline
scaled :  Ord a
       => (scale : Size -> (origin,bound : a) -> a)
       -> (origin,lower,upper : a)
       -> Range a
scaled f o l u = MkRange o $ \sz => let x_sized = clamp l u $ f sz o l
                                        y_sized = clamp l u $ f sz o u
                                     in (x_sized, y_sized)

||| Construct a range which scales the bounds relative to the size parameter.
|||
||| >>> bounds 0 $ linearFrom 0 (-10) 10
||| (0,0)
|||
||| >>> bounds 50 $ linearFrom 0 (-10) 20
||| (-5,10)
|||
||| >>> bounds 100 $ linearFrom 0 (-10) 20
||| (-10,20)
export
linearFrom : Ord a => ToInteger a => (origin,lower,upper : a) -> Range a
linearFrom = scaled scaleLinear

export
linear : Ord a => ToInteger a => (origin,upper : a) -> Range a
linear origin upper = linearFrom origin origin upper

export
linearFin : (n : Nat) -> Range (Fin $ S n)
linearFin n = map toFin $ linearFrom 0 0 (natToInteger n)
  where toFin : Integer -> Fin (S n)
        toFin k = fromMaybe FZ (integerToFin k (S n))

||| Construct a range which scales the bounds relative to the size parameter.
|||
||| This works the same as 'linearFrom', but for fractional values.
export
linearFracFrom :  (Neg a, Ord a, Fractional a)
               => (origin,lower,uppder : a) -> Range a
linearFracFrom = scaled scaleLinearFrac

||| Construct a range which is scaled relative to the size parameter and uses
||| the full range of a data type.
|||
||| >>> bounds 0 (linearBounded :: Range Int8)
||| (0,0)
|||
||| >>> bounds 50 (linearBounded :: Range Int8)
||| (-64,64)
|||
||| >>> bounds 99 (linearBounded :: Range Int8)
|||   (-128,127)
export
linearBounded :  (MinBound a, MaxBound a, Ord a, ToInteger a) => Range a
linearBounded = linearFrom minBound minBound maxBound

--------------------------------------------------------------------------------
--          Exponential Ranges
--------------------------------------------------------------------------------

EulerMinus1 : Double
EulerMinus1 = euler - 1

||| Scale a floating-point number exponentially with the size parameter.
|||
||| Note : This scales the difference between the two values exponentially.
export
scaleExponentialDouble : Size -> (origin,bound : Double) -> Double
scaleExponentialDouble sz o b =
  let e     = fromIntegral sz / 100.0
      delta = b - o
      diff  = pow (abs delta + 1) e - 1
   in o + diff * signum delta

||| Scale an integral exponentially with the size parameter.
export
scaleExponential : ToInteger a => Size -> (origin,bound : a) -> a
scaleExponential sz o b =
  round (scaleExponentialDouble sz (fromIntegral o) (fromIntegral b))

export
exponentialDoubleFrom : (origin,lower,upper : Double) -> Range Double
exponentialDoubleFrom = scaled scaleExponentialDouble

export
exponentialDouble : (lower,upper : Double) -> Range Double
exponentialDouble l u = exponentialDoubleFrom l l u

export
exponentialFrom : Ord a => ToInteger a => (origin,lower,upper : a) -> Range a
exponentialFrom = scaled scaleExponential

export
exponential : Ord a => ToInteger a => (lower,upper : a) -> Range a
exponential l u = exponentialFrom l l u

export
exponentialFin : (n : Nat) -> Range (Fin $ S n)
exponentialFin n = map toFin $ exponentialFrom 0 0 (natToInteger n)
  where toFin : Integer -> Fin (S n)
        toFin k = fromMaybe FZ (integerToFin k (S n))

--------------------------------------------------------------------------------
--          Tests and Proofs
--------------------------------------------------------------------------------

singletonOriginId : origin (singleton x) = x
singletonOriginId = Refl

singletonBoundsId : bounds s (singleton x) = (x,x)
singletonBoundsId = Refl

constantFromOrigin : origin (constantFrom o l u) = o
constantFromOrigin = Refl

constantFromBounds : bounds s (constantFrom o l u) = (l,u)
constantFromBounds = Refl

constantOrigin : origin (constant o u) = o
constantOrigin = Refl

constantBounds : bounds s (constant o u) = (o,u)
constantBounds = Refl

One : Int
One = 1

Zero : Int
Zero = 0

clamp1_100_0 : clamp One 100 0 = One
clamp1_100_0 = Refl

clamp100_1_0 : clamp 100 One 0 = One
clamp100_1_0 = Refl

clamp1_100_150 : clamp One 100 150 = 100
clamp1_100_150 = Refl

clamp100_1_150 : clamp 100 One 150 = 100
clamp100_1_150 = Refl

clamp1_100_50 : clamp One 100 50 = 50
clamp1_100_50 = Refl

clamp100_1_50 : clamp 100 One 50 = 50
clamp100_1_50 = Refl


module Utils.Time

import Utils.Num
import Data.Fin
import Data.String.Parser
import Data.Vect
import Data.String
import Data.Fin.Extra
import Utils.Misc
import Decidable.Equality
import Generics.Derive

%language ElabReflection

public export
data Month : Type where
  January : Month
  February : Month
  March : Month
  April : Month
  May : Month
  June : Month
  July : Month
  August : Month
  September : Month
  October : Month
  November : Month
  December : Month

export
next_month : Month -> Month
next_month January    = February
next_month February   = March
next_month March      = April
next_month April      = May
next_month May        = June
next_month June       = July
next_month July       = August
next_month August     = September
next_month September  = October
next_month October    = November
next_month November   = December
next_month December   = January

export
prev_month : Month -> Month
prev_month January    = December
prev_month February   = January
prev_month March      = February
prev_month April      = March
prev_month May        = April
prev_month June       = May
prev_month July       = June
prev_month August     = July
prev_month September  = August
prev_month October    = September
prev_month November   = October
prev_month December   = November

public export
next_prev_month : (m : Month) -> (next_month $ prev_month m) = m
next_prev_month January    = Refl
next_prev_month February   = Refl
next_prev_month March      = Refl
next_prev_month April      = Refl
next_prev_month May        = Refl
next_prev_month June       = Refl
next_prev_month July       = Refl
next_prev_month August     = Refl
next_prev_month September  = Refl
next_prev_month October    = Refl
next_prev_month November   = Refl
next_prev_month December   = Refl

public export
prev_next_month : (m : Month) -> (prev_month $ next_month m) = m
prev_next_month January    = Refl
prev_next_month February   = Refl
prev_next_month March      = Refl
prev_next_month April      = Refl
prev_next_month May        = Refl
prev_next_month June       = Refl
prev_next_month July       = Refl
prev_next_month August     = Refl
prev_next_month September  = Refl
prev_next_month October    = Refl
prev_next_month November   = Refl
prev_next_month December   = Refl

export
nat_to_month : Nat -> Maybe Month
nat_to_month 1  = Just January
nat_to_month 2  = Just February
nat_to_month 3  = Just March
nat_to_month 4  = Just April
nat_to_month 5  = Just May
nat_to_month 6  = Just June
nat_to_month 7  = Just July
nat_to_month 8  = Just August
nat_to_month 9  = Just September
nat_to_month 10 = Just October
nat_to_month 11 = Just November
nat_to_month 12 = Just December
nat_to_month _ = Nothing

export
fin_to_month : Fin 12 -> Month
fin_to_month 0  = January
fin_to_month 1  = February
fin_to_month 2  = March
fin_to_month 3  = April
fin_to_month 4  = May
fin_to_month 5  = June
fin_to_month 6  = July
fin_to_month 7  = August
fin_to_month 8  = September
fin_to_month 9  = October
fin_to_month 10 = November
fin_to_month 11 = December

export
month_to_nat : Month -> Nat
month_to_nat January   = 1
month_to_nat February  = 2
month_to_nat March     = 3
month_to_nat April     = 4
month_to_nat May       = 5
month_to_nat June      = 6
month_to_nat July      = 7
month_to_nat August    = 8
month_to_nat September = 9
month_to_nat October   = 10
month_to_nat November  = 11
month_to_nat December  = 12

export
month_num_of_dates : Integer -> Month -> Nat
month_num_of_dates _ January = 31
month_num_of_dates year February =
  if year `mod` 4 /= 0 then 28
    else if year `mod` 100 /= 0 then 29
    else if year `mod` 400 /= 0 then 28
    else 29
month_num_of_dates _ March = 31
month_num_of_dates _ April = 30
month_num_of_dates _ May = 31
month_num_of_dates _ June = 30
month_num_of_dates _ July = 31
month_num_of_dates _ August = 31
month_num_of_dates _ September = 30
month_num_of_dates _ October = 31
month_num_of_dates _ November = 30
month_num_of_dates _ December = 31

%runElab derive "Month" [Generic, Meta, DecEq, Eq, Ord, Show]

public export
data FinNonZero : Fin n -> Type where
  FSIsNonZero : FinNonZero (FS x)

show_nat_pad : Nat -> Nat -> String
show_nat_pad p n =
  let str = show n
      pad_len = minus p $ length str
      pad = replicate pad_len '0'
  in pad <+> str

show_fin_pad : Nat -> Fin n -> String
show_fin_pad p n = show_nat_pad p $ finToNat n

public export
record Date where
  constructor MkDate
  year : Integer
  month : Month
  day : Fin (S (month_num_of_dates year month))
  day_non_zero : FinNonZero day

export
epoch_date : Date
epoch_date = MkDate 1970 January 1 FSIsNonZero

export
Eq Date where
  a == b =
    case decEq a.year b.year of
      Yes prf0 =>
        case decEq a.month b.month of
          Yes prf1 => a.day == (rewrite prf0 in rewrite prf1 in b.day)
          No _ => False
      No _ => False

export
Ord Date where
  a `compare` b =
    case decEq a.year b.year of
      Yes prf0 =>
        case decEq a.month b.month of
          Yes prf1 =>
            let b_day = rewrite prf0 in rewrite prf1 in b.day
            in a.day `compare` b_day
          No _ => a.month `compare` b.month
      No _ => a.year `compare` b.year

export
Show Date where
  show date =
    (show $ date.year)
    <+> "/"
    <+> (show $ month_to_nat date.month)
    <+> "/"
    <+> (show_fin_pad 2 date.day)

date_to_tuple : Date -> (Integer, Integer, Integer)
date_to_tuple date = (date.year, natToInteger $ pred $ month_to_nat date.month, finToInteger date.day - 1)

date_to_normalized_tuple : Date -> (Integer, Month, Integer)
date_to_normalized_tuple date = (date.year, date.month, finToInteger date.day - 1)

tuple_normalize_month : (Integer, Integer, Integer) -> (Integer, Month, Integer)
tuple_normalize_month (year, month, day) =
  ( if month >= 0 then year + month `div` 12 else year + ((month + 1) `div` 12) - 1
  , fin_to_month $ modFinNZ (integerToNat $ month `mod'` 12) 12 SIsNonZero
  , day)

tuple_normalize_next_month : (Integer, Month, Integer) -> (Integer, Month, Integer)
tuple_normalize_next_month (year, month, day) =
  let next = next_month month
      new_year = case month of { December => year + 1; _ => year; }
  in (new_year, next, day - (natToInteger $ month_num_of_dates year month))

tuple_normalize_prev_month : (Integer, Month, Integer) -> (Integer, Month, Integer)
tuple_normalize_prev_month (year, month, day) =
  let prev = prev_month month
      new_year = case month of { January => year - 1; _ => year; }
  in (new_year, prev, day + (natToInteger $ month_num_of_dates year prev))

tuple_normalize_day : (Integer, Month, Integer) -> Date
tuple_normalize_day (year, month, day) =
  case integerToFin day (month_num_of_dates year month) of
    Just day' => MkDate year month (FS day') FSIsNonZero
    Nothing =>
      if day < 0
        then tuple_normalize_day $ tuple_normalize_prev_month (year, month, day)
        else tuple_normalize_day $ tuple_normalize_next_month (year, month, day)

tuple_normalize_date : (Integer, Integer, Integer) -> Date
tuple_normalize_date = tuple_normalize_day . tuple_normalize_month

days_between_dates' : (Integer, Month, Integer) -> (Integer, Month, Integer) -> Integer
days_between_dates' a@(a_year, a_month, a_day) b@(b_year, b_month, b_day) =
  case collapse_ordering [a_year `compare` b_year, a_month `compare` b_month] of
    LT => days_between_dates' (tuple_normalize_next_month a) b
    GT => days_between_dates' (tuple_normalize_prev_month a) b
    EQ => a_day - b_day

export
days_between_dates : Date -> Date -> Integer
days_between_dates a b = days_between_dates' (date_to_normalized_tuple a) (date_to_normalized_tuple b)

day_in_seconds : Nat
day_in_seconds = 24 * 60 * 60

day_in_milliseconds : Nat
day_in_milliseconds = 24 * 60 * 60 * 1000

day_in_seconds' : Integer
day_in_seconds' = natToInteger day_in_seconds

day_in_milliseconds' : Integer
day_in_milliseconds' = natToInteger day_in_milliseconds

public export
record DateTime where
  constructor MkDateTime
  date : Date
  hour : Fin 24
  minute : Fin 60
  second : Fin 60
  subsecond : Fin 1000
  offset_plus_or_minus : Bool
  hour_offset : Nat
  minute_offset : Fin 60

second_of_day : Nat -> (Fin 24, Fin 60, Fin 60)
second_of_day x =
  let second = modFinNZ x 60 SIsNonZero
      x = divNatNZ x 60 SIsNonZero
      minute = modFinNZ x 60 SIsNonZero
      x = divNatNZ x 60 SIsNonZero
      hour = modFinNZ x 24 SIsNonZero
  in (hour, minute, second)

export
epoch_to_datetime : Integer -> DateTime
epoch_to_datetime epoch =
  let (hour, minute, second) = second_of_day $ integerToNat $ epoch `mod'` day_in_seconds'
      dayno = if epoch >= 0 then epoch `div` day_in_seconds' else ((epoch + 1) `div` day_in_seconds') - 1
      date = tuple_normalize_date (1970, 0, dayno)
  in MkDateTime date hour minute second 0 True 0 0

export
millisecond_epoch_to_datetime : Integer -> DateTime
millisecond_epoch_to_datetime epoch =
  let subsecond' = integerToNat $ epoch `mod'` 1000
  in { subsecond := modFinNZ subsecond' 1000 SIsNonZero } (epoch_to_datetime $ epoch `div` 1000)

datetime_to_epoch' : DateTime -> Integer
datetime_to_epoch' datetime =
  (days_between_dates datetime.date epoch_date) * day_in_seconds'
  + (finToInteger datetime.hour * 60 * 60)
  + (finToInteger datetime.minute * 60)
  + (finToInteger datetime.second)

millisecond_datetime_to_epoch' : DateTime -> Integer
millisecond_datetime_to_epoch' datetime = (datetime_to_epoch' datetime) * 1000 + finToInteger datetime.subsecond

export
gmt_datetime : DateTime -> DateTime
gmt_datetime datetime =
  let epoch = millisecond_datetime_to_epoch' datetime
      offset = (1000 * 3600 * natToInteger datetime.hour_offset) + (1000 * 60 * finToInteger datetime.minute_offset)
      epoch = if datetime.offset_plus_or_minus then epoch - offset else epoch + offset
  in millisecond_epoch_to_datetime epoch

export
datetime_to_epoch : DateTime -> Integer
datetime_to_epoch = datetime_to_epoch' . gmt_datetime

export
millisecond_datetime_to_epoch : DateTime -> Integer
millisecond_datetime_to_epoch = millisecond_datetime_to_epoch' . gmt_datetime

export
Show DateTime where
  show datetime =
    (show $ datetime.date)
    <+> " "
    <+> (show_fin_pad 2 datetime.hour)
    <+> ":"
    <+> (show_fin_pad 2 datetime.minute)
    <+> ":"
    <+> (show_fin_pad 2 datetime.second)
    <+> "."
    <+> (show_fin_pad 3 datetime.subsecond)
    <+> " "
    <+> (if datetime.offset_plus_or_minus then "+" else "-")
    <+> (show_nat_pad 2 datetime.hour_offset)
    <+> ":"
    <+> (show_fin_pad 2 datetime.minute_offset)

fromDigits : Num a => (Fin 10 -> a) -> List (Fin 10) -> a
fromDigits f xs = foldl addDigit 0 xs
  where
    addDigit : a -> Fin 10 -> a
    addDigit num d = 10*num + f d

natFromDigits : List (Fin 10) -> Nat
natFromDigits = fromDigits finToNat

natFromNDigits : Monad m => Nat -> ParseT m Nat
natFromNDigits n = natFromDigits . toList <$> ntimes n digit

finNFromNDigits : Monad m => String -> (n : Nat) -> Nat -> ParseT m (Fin n)
finNFromNDigits name bound n = do
  number <- natFromNDigits n
  case natToFin number bound of
    Just fin => pure fin
    Nothing => fail $ "invalid " <+> name <+> ": " <+> show number

export
utc_time : Monad m => ParseT m DateTime
utc_time = do
  yy <- natFromDigits . toList <$> ntimes 2 digit
  mm <- natFromDigits . toList <$> ntimes 2 digit
  let year = if yy < 50 then 2000 + natToInteger yy else 1900 + natToInteger yy
  let Just month = nat_to_month mm
  | Nothing => fail $ "invalid month: " <+> show mm
  FS fs_day <- finNFromNDigits "day" (S $ month_num_of_dates year month) 2
  | FZ => fail "invalid day: 0"
  hour <- finNFromNDigits "hour" 24 2
  minute <- finNFromNDigits "minute" 60 2
  second <- option 0 $ finNFromNDigits "second" 60 2
  sign <- satisfy (const True)
  let date = MkDate year month (FS fs_day) FSIsNonZero
  let mk_date_time = MkDateTime date hour minute second 0
  case sign of
    'Z' => pure $ mk_date_time True 0 0
    '+' => uncurry (mk_date_time True) <$> utc_time_offset
    '-' => uncurry (mk_date_time False) <$> utc_time_offset
    err => fail $ "unrecognized timezone sign: " <+> show err
  where
    utc_time_offset : ParseT m (Nat, Fin 60)
    utc_time_offset = do
      hh <- natFromDigits . toList <$> ntimes 2 digit
      minute_off <- finNFromNDigits "minute offset" 60 2
      pure (hh, minute_off)

export
generalized_time : Monad m => ParseT m DateTime
generalized_time = do
  year <- natToInteger . natFromDigits . toList <$> ntimes 4 digit
  mm <- natFromDigits . toList <$> ntimes 2 digit
  let Just month = nat_to_month mm
  | Nothing => fail $ "invalid month: " <+> show mm

  FS fs_day <- finNFromNDigits "day" (S $ month_num_of_dates year month) 2
  | FZ => fail "invalid day: 0"

  hour <- finNFromNDigits "hour" 24 2
  minute <- option 0 $ finNFromNDigits "minute" 60 2
  second <- option 0 $ finNFromNDigits "second" 60 2

  subsecond <- option 0 subsecond

  sign <- satisfy (const True)
  let date = MkDate year month (FS fs_day) FSIsNonZero
  let mk_date_time = MkDateTime date hour minute second subsecond
  case sign of
    'Z' => pure $ mk_date_time True 0 0
    '+' => uncurry (mk_date_time True) <$> utc_time_offset
    '-' => uncurry (mk_date_time False) <$> utc_time_offset
    err => fail $ "unrecognized timezone sign: " <+> show err
  where
    utc_time_offset : ParseT m (Nat, Fin 60)
    utc_time_offset = do
      hh <- natFromDigits . toList <$> ntimes 2 digit
      minute_off <- finNFromNDigits "minute offset" 60 2
      pure (hh, minute_off)
    subsecond : ParseT m (Fin 1000)
    subsecond = do
      a <- char '.' *> natFromNDigits 1
      b <- option 0 $ natFromNDigits 1
      c <- option 0 $ natFromNDigits 1
      case natToFin (a * 100 + b * 10 + c) 1000 of
        Just x => pure x
        Nothing => fail "how"

export
parse_utc_time : String -> Either String DateTime
parse_utc_time = map fst . parse utc_time

export
parse_generalized_time : String -> Either String DateTime
parse_generalized_time = map fst . parse generalized_time


module Utils.Base64

import Control.Monad.Trans
import Data.Bits
import Data.List
import Data.String.Parser
import Data.Vect
import Utils.Bytes
import Utils.Misc

alphabets : Vect 64 Char
alphabets = fromList $ unpack "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

padding : Char
padding = '='

base64_chr : Monad m => ParseT m (Fin 64)
base64_chr = do
  c <- satisfy $ const True
  case elemIndex c alphabets of
    Just i => pure i
    Nothing => fail $ "invalid base64 character: " <+> show c

export
is_base64_char : Char -> Bool
is_base64_char c = isAlphaNum c || (c == '+') || (c == '/') || (c == '=')

many_to_bits8 : List Bits8 -> Either String (List Bits8)
many_to_bits8 [] = Right []
many_to_bits8 [x] = Left "underfed, not enough base64 chars"
many_to_bits8 [a, b] = Right [ (shiftL a 2) .|. (shiftR b 4) ]
many_to_bits8 [a, b, c] = Right [ (shiftL a 2) .|. (shiftR b 4), (shiftL b 4) .|. (shiftR c 2) ]
many_to_bits8 (a :: b :: c :: d :: xs) = map (four_to_three a b c d <+>) (many_to_bits8 xs)
  where
    four_to_three : Bits8 -> Bits8 -> Bits8 -> Bits8 -> List Bits8
    four_to_three a b c d = [(shiftL a 2) .|. (shiftR b 4), (shiftL b 4) .|. (shiftR c 2), (shiftL (c .&. 0b11) 6) .|. d]

parse_base64 : Monad m => ParseT m (List Bits8)
parse_base64 = do
  alphas <- many base64_chr
  _ <- many (char padding)
  case many_to_bits8 (cast . finToInteger <$> alphas) of
    Right x => pure x
    Left err => fail err

three_to_four : Bits8 -> Bits8 -> Bits8 -> List Char
three_to_four a b c =
  let i = shiftR a 2
      j = (shiftL (a .&. 0b11) 4) .|. (shiftR b 4)
      k = (shiftL (b .&. 0b1111) 2) .|. (shiftR c 6)
      l = c .&. 0b111111
      ijkl =
        [ modFinNZ (cast i) 64 SIsNonZero
        , modFinNZ (cast j) 64 SIsNonZero
        , modFinNZ (cast k) 64 SIsNonZero
        , modFinNZ (cast l) 64 SIsNonZero
        ]
  in (\x => index x alphabets) <$> ijkl

bits8_to_many : List Bits8 -> List Char
bits8_to_many [] = []
bits8_to_many [a] = (take 2 $ three_to_four a 0 0) <+> [padding, padding]
bits8_to_many [a, b] = (take 3 $ three_to_four a b 0) <+> [padding]
bits8_to_many (a :: b :: c :: xs) = three_to_four a b c <+> bits8_to_many xs

export
base64_decode : String -> Either String (List Bits8)
base64_decode = map fst . parse parse_base64

export
base64_encode : List Bits8 -> String
base64_encode = pack . bits8_to_many


|||
module Toolkit.Data.Graph.EdgeBounded.HasExactDegree.All

import Decidable.Equality

import Data.String
import Data.List.Elem
import Data.List.Quantifiers

import Toolkit.Decidable.Do
import Toolkit.Decidable.Informative

import Toolkit.Data.Nat
import Toolkit.Data.Pair
import Toolkit.Data.List.Size
import Toolkit.Data.List.Occurs.Does

import Toolkit.Data.Graph.EdgeBounded

import public Toolkit.Data.Graph.EdgeBounded.DegreeCommon
import public Toolkit.Data.Graph.EdgeBounded.HasExactDegree

%default total

public export
HasExactDegrees : Vertices type -> Edges -> Type
HasExactDegrees vs es = All (\v => HasExactDegree v es) vs

errorHead : {x : type}
         -> {p : type -> Type}
         -> (p x -> Void)
         -> All p (x :: xs) -> Void
errorHead contra (y :: z) = contra y

errorTail : (All p xs -> Void) -> All p (x :: xs) -> Void
errorTail f (y :: z) = f z

all : {type : Type}
   -> {p  : type -> Type}
   -> (f  : (x : type) -> DecInfo e (p x))
   -> (xs : List type)
         -> DecInfo e (All p xs)
all f [] = Yes []
all f (x :: xs) with (f x)
  all f (x :: xs) | (Yes prfWhy) with (all f xs)
    all f (x :: xs) | (Yes prfWhy) | (Yes y)
      = Yes (prfWhy :: y)
    all f (x :: xs) | (Yes prfWhy) | (No msgWhyNot prfWhyNot)
      = No msgWhyNot (errorTail prfWhyNot)

  all f (x :: xs) | (No msgWhyNot prfWhyNot) = No msgWhyNot (errorHead prfWhyNot)

export
hasExactDegrees : {type : Type}
               -> (vs   : Vertices type)
               -> (es   : Edges)
                       -> DecInfo (HasExactDegree.Error type)
                                  (HasExactDegrees vs es)
hasExactDegrees vs es = all (\v => hasExactDegree v es) vs

-- [ EOF ]