> module SequentialDecisionProblems.CoreTheory

> import Sigma.Sigma
> import Sigma.Operations

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

* Preliminaries

In a nutshell, the core theory introduces the notion of policy, policy
sequence, optimality of policy sequences and implements a generic
backwards induction algorithm |backwardsInduction| for computing optimal
policy sequences.

However, the core theory does not implement a machine checkable proof
that |backwardsInduction| is correct that is, that its result is an
optimal policy sequence.

This is done in the full theory presented in |FullTheory|. Both here and
in |FullTheory|, the assumptions are implemented as holes
(metavariables, forward declarations, partial definitions, etc.). The
idea is that users that wish to apply the theory (typically, for
computing optimal solutions for a specific decision problem) will
fill-in the holes by providing problem-specific implementations.

* Sequential decision processes

A sequential decision problem (SDP) is specified in terms of, among
others, its underlying decision process.

In a decision process, a decision maker is required to perform a number
of decision steps. At each step, the decision maker is in (observes) a
state and is required to select a control (action, option). The idea is
that, upon selecting a control in a given state, the decision maker will
enter (observe) a new state. In a deterministic decision process, such
new state is uniquely defined in terms of the current decision step,
state and selected control. But in decision processes under uncertainty,
the decision maker only knows which new states are "possible" (again,
for a given decision step, "current" state and selected control) and,
perhaps, their probabilities. But it does not know which one will
actually occur.

Thus, in order to specify a decision process, one has to first specify
what are the possible states at each decision step:

> State : (t : Nat) -> Type

Then, one has to explain which controls can be selected at a given step
and for a given state:

> Ctrl : (t : Nat) -> (x : State t) -> Type

Finally, one has to explain which "next" states are possible at a given
decision step, in a given state and for a selected control. In the
deterministic case, one could provide such explanation by defining a
stepping function

< next : (t : Nat) -> (x : State t) -> (y : Ctrl t x) -> State (S t)

But what if the decision process has uncertain outcomes? In this case,
we follow an approach originally proposed by Ionescu [1] and generalize
|next| to a monadic transition function:

> M : Type -> Type

> nexts : (t : Nat) -> (x : State t) -> (y : Ctrl t x) -> M (State (S t))

For reasons that will become clear in the sequel, |M| is is required
to be a functor:

> fmap  :  {A, B : Type} ->
>          (A -> B) -> M A -> M B
> postulate functorSpec1  :  fmap . id = id
> postulate functorSpec2  :  {A, B, C : Type} -> {f : B -> C} -> {g : A -> B} ->
>                            fmap (f . g) = (fmap f) . (fmap g)

In the above specification and throughout this file, we use postulates
to denote assumptions that we consider to be conceptually relevant but
that are not necessary for the theory. Thus, strictly speaking, |M| is
not required to be a functor, just to implement |fmap|.

In specific decision processes, we expect |M| to be |Id| (deterministic
SDP), |List| (non-deterministic SDP) or |Prob| (stochastic SDP). But our
assumptions are general enough to specify other kinds of decision
processes.

* Sequential decision problems

In order to obtain a problem from a decision process, we introduce the
additional assumption that, with each transition from the current state
to a new state, the decision maker receives a certain reward (payoff,
etc.)

> Val : Type

> reward : (t : Nat) -> (x : State t) -> (y : Ctrl t x) -> (x' : State (S t)) -> Val

Since the original work of Bellman [1957], this has turned out to be a
useful abstraction. The idea is that the decision maker seeks controls
that maximize the sum of the rewards obtained in a decision
process. Thus, values of type |Val| have to be "addable"

> plus : Val -> Val -> Val

We will also need |Val| to be equipped with a "zero"

> zero : Val

and with a binary "comparison" relation

> LTE : Val -> Val -> Type

In a deterministic case, implementing the above assumptions completely
defines a sequential decision problem. But whenever a decision step has
an uncertain outcome, uncertainties about "next" states naturally yield
uncertainties about rewards. In these cases, the decision makes faces a
number of possible rewards (one for each possible next state) and has to
explain how it measures such chances. In stochastic decision problems,
possible next states (and, therefore possible rewards) are labelled with
probabilities. In these cases, possible rewards are often measured in
terms of their expected value.  Here, again, we follow the approach
proposed by Ionescu in [2] and introduce a measure

> meas : M Val -> Val

that characterizes how the decision maker values uncertainties about
rewards in a single decision step. It is possible that a decision maker
values uncertainties according to different measures at different
decision steps. This could be easily formalized by generalising

< meas : M Val -> Val

to

< meas : (t : Nat) -> (x : State t) -> (M Val -> Val)

* Solving sequential decision problems

Implementing the above holes defines a specific SDP unambiguously. But
in order to compute controls that maximize the sum of the rewards over
an arbitrary number of decision steps, we need to be able to assess that
all "next" states in an |M|-structure satisfy certain properties. This
requires |M| to be a "container":

> Elem     : {A : Type} -> A -> M A -> Type
> NotEmpty : {A : Type} -> M A -> Type
> All      : {A : Type} -> (P : A -> Type) -> M A -> Type
> tagElem  : {A : Type} -> (ma : M A) -> M (Sigma A (\ a => a `Elem` ma))

> allElemSpec0                 :  {A : Type} -> {P : A -> Type} ->
>                                 (a : A) -> (ma : M A) -> All P ma -> a `Elem` ma -> P a

> postulate elemNotEmptySpec0  :  {A : Type} ->
>                                 (a : A) -> (ma : M A) -> a `Elem` ma -> NotEmpty ma

> postulate elemNotEmptySpec1  :  {A : Type} ->
>                                 (ma : M A) -> NotEmpty ma -> Sigma A (\ a => a `Elem` ma)

> postulate tagElemSpec        :  {A : Type} -> (ma : M A) -> fmap outl (tagElem ma) = ma

The theory presented here relies on two further notions: viability and
reachability.

* Viability

Intuitively, a state |x : State t| is viable for |n| steps if, in spite
of the uncertainties of the decision process, one can make |n| decision
steps starting from |x| without bumping into a dead end. Here, dead ends
are states for which no controls are available. In concrete decision
problems, they could represent exceptional outcomes: aborting a
computation, running out of fuel, being shot dead.

> Viable : {t : Nat} -> (n : Nat) -> State t -> Type

Thus, every state is viable for zero steps

> postulate viableSpec0 : {t : Nat} ->
>                         (x : State t) -> Viable Z x

and a state is viable for |S n| steps iff there exists a control that
leads to a non-empty |M|-structure of next states which are viable for
|n| steps. We call such controls "good" controls:

> Good : (t : Nat) -> (x : State t) -> (n : Nat) -> (Ctrl t x) -> Type
> Good t x n y = (NotEmpty (nexts t x y), All (Viable {t = S t} n) (nexts t x y))

> GoodCtrl : (t : Nat) -> (x : State t) -> (n : Nat) -> Type
> GoodCtrl t x n = Sigma (Ctrl t x) (Good t x n)
> -- GoodCtrl t x n = Sigma (Ctrl t x) (\ y => (NotEmpty (nexts t x y), All (Viable {t = S t} n) (nexts t x y)))

> viableSpec1 : {t : Nat} -> {n : Nat} ->
>               (x : State t) -> Viable (S n) x -> GoodCtrl t x n

> postulate viableSpec2 : {t : Nat} -> {n : Nat} ->
>                         (x : State t) -> GoodCtrl t x n -> Viable (S n) x

Auxiliary functions:

> |||
> ctrl : {t, n : Nat} -> {x : State t} -> GoodCtrl t x n -> Ctrl t x
> ctrl (MkSigma y _) = y

> |||
> -- good : {t, n : Nat} -> {x : State t} -> (y : GoodCtrl t x n) -> Good t x n (ctrl y)
> -- good (MkSigma _ p) = p

> |||
> allViable : {t, n : Nat} -> {x : State t} -> (y : GoodCtrl t x n) -> All (Viable n) (nexts t x (ctrl y))
> allViable (MkSigma _ p) = snd p

* Reachability

Viability is, strictly speaking, all what is needed to formalize the
notion of policies as functions that associate "good" controls to
viable states.

But in a decision problem, not all viable states are actually
reachable. Thus, we would like to further restrict the domain of
policies to states that can actually be reached. Intuitively, a state is
reachable if there are controls that allow for a path from some initial
state to that state. Thus, tautologically, every initial state is
reachable:

> Reachable : {t' : Nat} -> State t' -> Type

> postulate reachableSpec0 : (x : State Z) -> Reachable x

Moreover, if |x| is reachable and admits a control |y|, then all states
that can be obtained by selecting |y| in |x| are also reachable:

> reachableSpec1  :  {t : Nat} -> (x : State t) -> Reachable x -> (y : Ctrl t x) -> All Reachable (nexts t x y)

And the other way round:

> Pred : {t : Nat} -> State t -> State (S t) -> Type
> Pred {t} x x'  =  Sigma (Ctrl t x) (\ y => x' `Elem` nexts t x y)

> ReachablePred : {t : Nat} -> State t -> State (S t) -> Type
> ReachablePred x x'  = (Reachable x, x `Pred` x')

> postulate reachableSpec2  :  {t : Nat} -> (x' : State (S t)) -> Reachable x' -> Sigma (State t) (\ x => x `ReachablePred` x')

* Policies and policy sequences

Policies are functions that associate to every state |x| at decision
step |t| which is reachable and viable for |S m| steps (from which |S
m| more decision steps are doable) a good control:

> Policy : (t : Nat) -> (n : Nat) -> Type
> Policy t Z      =  Unit
> Policy t (S m)  =  (x : State t) -> Reachable x -> Viable (S m) x -> GoodCtrl t x m

A policy sequence for making |n| decision steps starting from some
(reachable, viable for |n| steps) state at decision step |t| is a list
of policies of length |n|, one for each decision step:

> data PolicySeq : (t : Nat) -> (n : Nat) -> Type where
>   Nil   :  {t : Nat} ->
>            PolicySeq t Z
>   (::)  :  {t, n : Nat} ->
>            Policy t (S n) -> PolicySeq (S t) n -> PolicySeq t (S n)

Fold for |PolicySeq|:

> foldPolicySeq : {X : (t : Nat) -> (n : Nat) -> Type} ->
>                 ((t : Nat) -> X t Z) ->
>                 ((t : Nat) -> (n : Nat) -> Policy t (S n) -> X (S t) n -> X t (S n)) ->
>                 (t : Nat) -> (n : Nat) -> PolicySeq t n -> X t n
> foldPolicySeq e f t Z Nil = e t
> foldPolicySeq e f t (S n) (p :: ps) = f t n p (foldPolicySeq e f (S t) n ps)

* The value of policy sequences

As mentioned before, the idea of a decision problem is that the
decision maker seeks controls that maximize the sum of the rewards
obtained in a decision process.

Thus, in order to meaningfully define a notion of optimality for policy
sequences, we have to compute the value (in terms of possible sums of
rewards) of making decisions according to a given policy sequence.

Specifically, for a policy sequence |ps : PolicySeq tn| and a reachable,
viable for |n| steps state |x : State t|, we have to compute the value
(in terms of possible sums of rewards) of making |n| decision steps with
|ps| starting from |x|:

<   val : {t : Nat} -> {n : Nat} ->
<         (x : State t) -> Reachable x -> Viable n x -> PolicySeq t n -> Val

The case |n = Z| (and |ps = Nil|) is trivial. Here, we are not making
any decision step. Thus, we do not collect any reward and the value is
just zero:

<   val {t} {n = Z} x r v ps = zero

If |n = S m| and |ps| consists of a policy |p : Policy t (S m)| and of a
policy sequence |ps : PolicySeq (S t) m|, things are more complicated:

<   val {t} {n = S m} x r v (p :: ps) = ?

Here, we first have to compute the rewards obtained by selecting the
control |y = ctrl (p x r v)| in the first decision step. We get one
possible reward for each state in |nexts t x y|. Thus, if |x' `Elem`
(nexts t x y)|, its corresponding reward is

< reward t x y x'

Next, we have to add to all these rewards (one for every |x'|) the
values of making |m| further decision steps with |ps| starting from
|x'|:

< val x' r' v' ps

To do so, we have to provide reachability and viability evidences |r'|
and |v'| for |x'|. Finally, we have to reduce all possible values to a
single aggregated value. Here is where the measure |meas| comes into
place.

It is useful to introduce the notion of those possible states that can
be obtained by selecting the control |y : Ctrl t x| in |x : State t|:

> PossibleNextState  :  {t : Nat} ->
>                       (x  : State t) -> (y : Ctrl t x) -> Type
> PossibleNextState {t} x y = Sigma (State (S t)) (\ x' => x' `Elem` (nexts t x y))

With this notion in place and assuming

<   val : {t : Nat} -> {n : Nat} ->
<         (x : State t) -> Reachable x -> Viable n x -> PolicySeq t n -> Val

to be available, we can implement

> mutual

>   sval  :  {t, m : Nat} ->
>            (x  : State t) -> (r  : Reachable x) -> (v  : Viable (S m) x) ->
>            (gy  : GoodCtrl t x m) -> (ps : PolicySeq (S t) m) ->
>            PossibleNextState x (ctrl gy) -> Val
> {-
>   sval {t} {m} x r v gy ps (MkSigma x' x'emx') = reward t x y x' `plus` val x' r' v' ps where
>     y   : Ctrl t x
>     y   = ctrl gy
>     mx' : M (State (S t))
>     mx' = nexts t x y
>     ar' : All Reachable mx'
>     ar' = reachableSpec1 x r y
>     av' : All (Viable m) mx'
>     av' = allViable gy
>     r'  : Reachable x'
>     r'  = allElemSpec0 x' mx' ar' x'emx'
>     v'  : Viable m x'
>     v'  = allElemSpec0 x' mx' av' x'emx'
> -}
>   sval {t} {m} x r v gy ps (MkSigma x' x'emx') =
>     let y   : Ctrl t x
>             = ctrl gy in
>     let mx' : M (State (S t))
>             = nexts t x y in
>     let ar' : All Reachable mx'
>             = reachableSpec1 x r y in
>     let av' : All (Viable m) mx'
>             = allViable gy in
>     let r'  : Reachable x'
>             = allElemSpec0 x' mx' ar' x'emx' in
>     let v'  : Viable m x'
>             = allElemSpec0 x' mx' av' x'emx' in
>     reward t x y x' `plus` val x' r' v' ps

And finally

>   val  :  {t, n : Nat} ->
>           (x : State t) -> (r : Reachable x) -> (v : Viable n x) -> PolicySeq t n -> Val
>   val {t} {n = Z} x r v ps = zero
>   val {t} {n = S m} x r v (p :: ps) = meas (fmap (sval x r v gy ps) (tagElem mx')) where
>     gy   :  GoodCtrl t x m
>     gy   =  p x r v
>     y    :  Ctrl t x
>     y    =  ctrl gy
>     mx'  :  M (State (S t))
>     mx'  =  nexts t x y

* Optimality of policy sequences

With a function for computing the value (in terms of "possible" sums
of rewards) of making |n| decision steps with a policy sequence
starting from some specific state, we can formalise what it means for
one such sequence to be optimal.

Informally, we say that a policy sequence |ps| for making |n| decision
steps starting from states in |State t| which are reachable and viable
for |n| steps is optimal if its value is at least as good as the value
of any other policy sequence for making |n| decision steps starting
from states in |State t|. Formally:

> |||
> OptPolicySeq  :  {t, n : Nat} ->
>                  PolicySeq t n -> Type
>
> {-
> OptPolicySeq {t} {n} ps  =  (ps' : PolicySeq t n) ->
>                             (x : State t) -> (r : Reachable x) -> (v : Viable n x) ->
>                             val x r v ps' `LTE` val x r v ps
> -}
> OptPolicySeq {t} {n} ps  =  (x : State t) -> (r : Reachable x) -> (v : Viable n x) ->
>                             (ps' : PolicySeq t n) ->
>                             val x r v ps' `LTE` val x r v ps

Notice that the above notion of optimality is very strong. It entails a
quantification over all (viable and reachable) states of |Stete t| to
which the first policy of the sequence can be applied.

Thus, if we manage to compute an optimal policy sequence of length |n|
for making |n| decisions starting from step |t|, we have the guarantee
that, no matter which state we will happen to be at decision step |t|,
there is no better way to make |n| decision steps than that encoded by
our policy.

In other words, we have |n| rules for making ``best'' (in terms of
``possible'' sums of rewards) decisions.

Thus, an obvious question is whether it is at all possible to compute
sequences of policies that are optimal in the above sense. As we shall
see in |FullTheory|, if the assumptions put forward here and in
|ExtraAssumptions| are fulfilled, the answer to this question is
positive.

In the rest of this file, we implement a generic backwards induction
algorithm for computing optimal policy sequences for an arbitrary number
of decision steps.

* Optimal extensions of policy sequences

The computation at the core of backwards induction is the computation
of an optimal extension of a policy sequence. An extension of a policy
sequence for making |m| decision steps starting from states at
decision step |S t| is just a policy for taking decisions at step |t|,
that is, a policy that is put *in front* of the list of policies that
will deal with any resulting future states.

Informally, a policy |p| is an optimal extension of a policy sequence
|ps| if there is no better way than |p :: ps| to make |S m| decision
steps at step |t|. Formally:

> |||
> OptExt  :  {t, m : Nat} ->
>            PolicySeq (S t) m -> Policy t (S m) -> Type
> {-
> OptExt {t} {m} ps p  =  (p' : Policy t (S m)) ->
>                         (x : State t) -> (r : Reachable x) -> (v : Viable (S m) x) ->
>                         val x r v (p' :: ps) `LTE` val x r v (p :: ps)
> -}
> OptExt {t} {m} ps p  =  (x : State t) -> (r : Reachable x) -> (v : Viable (S m) x) ->
>                         (p' : Policy t (S m)) ->
>                         val x r v (p' :: ps) `LTE` val x r v (p :: ps)

The idea behind the notion of optimal extension is that if |p| is an
optimal extension of |ps| and |ps| is optimal, then |p :: ps| is
optimal.  This is Bellman's principle of optimality [1] which we will
implement in |FullTheory|.

The strong requirement of optimality implies that |p| is optimal for
every state, therefore, the control obtained by applying |p| to a given
state |x| must be optimal, i.e., it must maximise the function |cval x r
v ps|:

> |||
> cval  :  {t, n : Nat} ->
>          (x : State t) -> (r : Reachable x) -> (v : Viable (S n) x) ->
>          (ps : PolicySeq (S t) n) -> GoodCtrl t x n -> Val
> cval {t} x r v ps gy = meas (fmap (sval x r v gy ps) (tagElem mx')) where
>   y    :  Ctrl t x
>   y    =  ctrl gy
>   mx'  :  M (State (S t))
>   mx'  =  nexts t x y

Let |cvalargmax| be a function that delivers the control that leads to
the maximal value of |cval x r v ps|:

> cvalargmax  :  {t, n : Nat} ->
>                (x  : State t) -> (r : Reachable x) -> (v : Viable (S n) x) ->
>                (ps : PolicySeq (S t) n) -> GoodCtrl t x n

The controls obtained by maximising |cval x r v ps| for each of the
states |x : State t| will deliver a policy which is an optimal extension
of |ps|.  Thus, the problem of maximising |val| has been reduced to the
maximisation of |cval| for the states at time |t|.  Therefore, the
function that computes this optimal extension is:

> |||
> optExt  :  {t, n : Nat} ->
>            PolicySeq (S t) n -> Policy t (S n)
> optExt {t} {n} ps = p where
>   p : Policy t (S n)
>   p x r v = cvalargmax x r v ps

* Generic machine checkable backwards induction

If |LTE| is reflexive, it is straightforward to show that empty policy
sequences (that is, sequences for performing zero decision steps) are
optimal. Therefore, we have a starting point for the recursive process
of extending optimal policy sequences. This suggests the following
implementations of backwards induction:

> backwardsInduction : (t : Nat) -> (n : Nat) -> PolicySeq t n
> backwardsInduction t  Z     =  Nil
> {-
> backwardsInduction t (S n)  =  optExt ps :: ps where
>   ps : PolicySeq (S t) n
>   ps = backwardsInduction (S t) n
> -}
> backwardsInduction t (S n)  =  let ps = backwardsInduction (S t) n in
>                                optExt ps :: ps

> {-

> take : {t : Nat} -> (n : Nat) -> (m : Nat) -> PolicySeq t n -> Sigma Nat (\ m' => PolicySeq t m')
> take {t}    Z   m          ps  = MkSigma Z Nil
> take {t} (S n)  Z          ps  = MkSigma Z Nil
> take {t} (S n) (S m) (p :: ps) = MkSigma (S m') (p' :: ps') where
>   mps' : Sigma Nat (\ m' => PolicySeq (S t) m')
>   mps' = take n m ps
>   m'   : Nat
>   m'   = outl mps'
>   ps'  : PolicySeq (S t) m'
>   ps'  = outr mps'
>   p'   : Policy t (S m')
>   p'   = ?this_might_work -- p

> bi : (t : Nat) -> (n : Nat) -> (m : Nat) -> PolicySeq t n
> bi t  Z    m  =  Nil
> bi t (S n) m  =  p :: ps where
>   ps        : PolicySeq (S t) n
>   ps        = bi (S t) n m
>   m'        : Nat
>   m'        = outl (take n m ps)
>   ps'       : PolicySeq (S t) m'
>   ps'       = outr (take n m ps)
>   p         : Policy t (S n)
>   p         = ?this_will_not_work -- optExt ps'

> -}

This file contains all the *computational* elements that the user must
specify in order to be able to run |backwardsInduction|.  The results
are going to fulfill the condition of optimality only if several
assumptions hold, some of which we have introduced only informally (and
others not at all).  For example, we have not formalised the requirement
that |cvalargmax| delivers an optimal control, or that |LTE| is
reflexive (and we haven't even mentioned its transitivity, which is also
required).

These additional assumptions are formulated in the file |FullTheory|,
where we also implement a machine-checked proof of the correctness of
|backwardsInduction| under these assumptions.

This separation has been introduced in order to enable users that do not
want to deal with formal proofs to use the framework for computing
optimal policies.  Of course, the optimality of the results will, in
this case, not be machine-checked.

> {-

> ---}

[1] Bellman, Richard; "Dynamic Programming", Princeton University Press,
    1957

[2] Ionescu, Cezar; "Vulnerability Modelling and Monadic Dynamical
    Systems", Freie Universitaet Berlin, 2009


module Example.Pil.AsC

import Example.Pil

export
Show Name where
  show (MkName n) = n

public export
0 allShows : Expression ctx a -> Type
allShows (C _) = Show a
allShows (V n) = ()
allShows (U _ e) = allShows e
allShows (B _ e1 e2) = (allShows e1, allShows e2)

export
show : (ex : Expression ctx a) -> (shows : allShows ex) => String
show (C x) = show x
show (V n) = show n
show (U f e) = "?(" ++ show e ++ ")"
show (B f e1 e2) = with Example.Pil.AsC.show "(" ++ show e1 {shows = fst shows} ++ ") ?? (" ++ show e2 {shows = snd shows} ++ ")"


||| Universal clock - Ported from Haskell time package.
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Time.Clock

import Data.Fixed
import Data.Rational

import public Data.Time.Clock.DiffTime
import public Data.Time.Clock.UTCTime
import Data.Time.Calendar

import Generics.Derive

%default total
%language ElabReflection

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

public export
record UniversalTime where
  constructor ModJulianDate
  modJulianDate : Rational
%runElab derive "UniversalTime" [Generic, Eq, Ord, DecEq]

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


{-
$ cd collatzProof_DivSeq/program3
$ chcp 65001
$ idris
> :l ProofColDivSeqMain
-}
module ProofColDivSeqMain

import ProofColDivSeqBase as B
import ProofColDivSeqPostulate
import Sub02LTE72t45
import Sub03LTE216t81
import Sub04LTE216t153
import Sub05LTE216t225
import Sub06LTE108t27
import Sub07LTE108t63
import Sub08LTE108t99
import Sub09LTE18t15
import Sub11LTE36t21
import Sub12LTE108t39
import Sub13LTE108t75
import Sub14LTE108t111

%default total

-- 示すのに、整礎帰納法を使っている
makeLimitedDivSeq :
  ((z : Nat) -> ((FirstLimited . B.allDivSeq) z -> (AllLimited . B.allDivSeq) z))
    ->  (n : Nat) -> (FirstLimited . B.allDivSeq) n
makeLimitedDivSeq firstToAll n = wfInd {P=(\z=>(FirstLimited . B.allDivSeq) z)} {rel=LT'} (step firstToAll) n where
  step : ((z : Nat) -> ((FirstLimited . B.allDivSeq) z -> (AllLimited . B.allDivSeq) z))
    -> (x : Nat) -> ((y : Nat) -> LT' y x -> (FirstLimited . B.allDivSeq) y)
      -> (FirstLimited . B.allDivSeq) x
  step _          Z     _  = IsFirstLimited10                                                          -- 6*<0>+3 = 3
  step firstToAll (S x) rs with (mod3 x)
    -- 0 mod 9
    step firstToAll (S (j + j + j)) rs | ThreeZero with (parity j)
      step firstToAll (S ((Z+Z) + (Z+Z) + (Z+Z)))             rs | ThreeZero | Even = IsFirstLimited01 -- 6*<1>+3 = 9
      step firstToAll (S (((S k)+(S k)) + ((S k)+(S k)) + ((S k)+(S k))))             rs | ThreeZero | Even with (parity k)
        step firstToAll (S (((S (l+l))+(S (l+l))) + ((S (l+l))+(S (l+l))) + ((S (l+l))+(S (l+l)))))                         rs | ThreeZero | Even | Even
          = (IsFirstLimited02 l . firstToAll l) (rs l $ lteToLt' $ lte72t45 l)
        step firstToAll (S (((S (S (l+l)))+(S (S (l+l)))) + ((S (S (l+l)))+(S (S (l+l)))) + ((S (S (l+l)))+(S (S (l+l)))))) rs | ThreeZero | Even | Odd  with (mod3 l)
          step firstToAll (S (((S (S ((m+m+m)+(m+m+m))))+(S (S ((m+m+m)+(m+m+m))))) + ((S (S ((m+m+m)+(m+m+m))))+(S (S ((m+m+m)+(m+m+m))))) + ((S (S ((m+m+m)+(m+m+m))))+(S (S ((m+m+m)+(m+m+m)))))))                                                                                rs | ThreeZero | Even | Odd | ThreeZero
            = (IsFirstLimited03 m . firstToAll (m+m)) (rs (m+m) $ lteToLt' $ lte216t81 m)
          step firstToAll (S (((S (S ((S (m+m+m))+(S (m+m+m)))))+(S (S ((S (m+m+m))+(S (m+m+m)))))) + ((S (S ((S (m+m+m))+(S (m+m+m)))))+(S (S ((S (m+m+m))+(S (m+m+m)))))) + ((S (S ((S (m+m+m))+(S (m+m+m)))))+(S (S ((S (m+m+m))+(S (m+m+m))))))))                                                 rs | ThreeZero | Even | Odd | ThreeOne
            = (IsFirstLimited04 m . firstToAll (S ((m+m)+(m+m)))) (rs (S ((m+m)+(m+m))) $ lteToLt' $ lte216t153 m)
          step firstToAll (S (((S (S ((S (S (m+m+m)))+(S (S (m+m+m))))))+(S (S ((S (S (m+m+m)))+(S (S (m+m+m))))))) + ((S (S ((S (S (m+m+m)))+(S (S (m+m+m))))))+(S (S ((S (S (m+m+m)))+(S (S (m+m+m))))))) + ((S (S ((S (S (m+m+m)))+(S (S (m+m+m))))))+(S (S ((S (S (m+m+m)))+(S (S (m+m+m))))))))) rs | ThreeZero | Even | Odd | ThreeTwo
            = (IsFirstLimited05 m . firstToAll (S (S (S (S (S (S (S (m+m+m+m)+(m+m+m+m))))))))) (rs (S (S (S (S (S (S (S (m+m+m+m)+(m+m+m+m)))))))) $ lteToLt' $ lte216t225 m)
      step firstToAll (S ((S (k+k)) + (S (k+k)) + (S (k+k)))) rs | ThreeZero | Odd  with (mod3 k)
        step firstToAll (S ((S ((l+l+l)+(l+l+l))) + (S ((l+l+l)+(l+l+l))) + (S ((l+l+l)+(l+l+l)))))                                                 rs | ThreeZero | Odd | ThreeZero
          = (IsFirstLimited06 l . firstToAll (S (S (S (l+l+l+l)+(l+l+l+l)+(l+l+l+l)+(l+l+l+l))))) (rs (S (S (S (l+l+l+l)+(l+l+l+l)+(l+l+l+l)+(l+l+l+l)))) $ lteToLt' $ lte108t27 l)
        step firstToAll (S ((S ((S (l+l+l))+(S (l+l+l)))) + (S ((S (l+l+l))+(S (l+l+l)))) + (S ((S (l+l+l))+(S (l+l+l))))))                         rs | ThreeZero | Odd | ThreeOne
          = (IsFirstLimited07 l . firstToAll (S (S (S (S (l+l+l+l)+(l+l+l+l)))))) (rs (S (S (S (S (l+l+l+l)+(l+l+l+l))))) $ lteToLt' $ lte108t63 l)
        step firstToAll (S ((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))))))) rs | ThreeZero | Odd | ThreeTwo
          = (IsFirstLimited08 l . firstToAll (S (S (S ((l+l)+(l+l)))))) (rs (S (S (S ((l+l)+(l+l))))) $ lteToLt' $ lte108t99 l)
    -- 6 mod 9
    step firstToAll (S (S (j + j + j)))     rs | ThreeOne
      = (IsFirstLimited09 j . firstToAll j) (rs j $ lteToLt' $ lte18t15 j)
    -- 3 mod 9
    step firstToAll (S (S (S (j + j + j)))) rs | ThreeTwo with (parity j)
      step firstToAll (S (S (S (   (k+k)  +    (k+k)  +    (k+k)))))  rs | ThreeTwo | Even
        = (IsFirstLimited11 k . firstToAll k) (rs k $ lteToLt' $ lte36t21 k)
      step firstToAll (S (S (S ((S (k+k)) + (S (k+k)) + (S (k+k)))))) rs | ThreeTwo | Odd  with (mod3 k)
        step firstToAll (S (S (S ((S ((l+l+l)+(l+l+l))) + (S ((l+l+l)+(l+l+l))) + (S ((l+l+l)+(l+l+l)))))))                                                 rs | ThreeTwo | Odd  | ThreeZero
          = (IsFirstLimited12 l . firstToAll (l+l)) (rs (l+l) $ lteToLt' $ lte108t39 l)
        step firstToAll (S (S (S ((S ((S (l+l+l))+(S (l+l+l)))) + (S ((S (l+l+l))+(S (l+l+l)))) + (S ((S (l+l+l))+(S (l+l+l))))))))                         rs | ThreeTwo | Odd  | ThreeOne
          = (IsFirstLimited13 l . firstToAll (S ((l+l)+(l+l)))) (rs (S ((l+l)+(l+l))) $ lteToLt' $ lte108t75 l)
        step firstToAll (S (S (S ((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))))))))) rs | ThreeTwo | Odd  | ThreeTwo
          = (IsFirstLimited14 l . firstToAll (S (S (S (S (S (S (S (l+l+l+l)+(l+l+l+l))))))))) (rs (S (S (S (S (S (S (S (l+l+l+l)+(l+l+l+l)))))))) $ lteToLt' $ lte108t111 l)

-- 十分条件
firstToAll :
  (z : Nat) -> ((FirstLimited . B.allDivSeq) z -> (AllLimited . B.allDivSeq) z)
firstToAll z first =
  let
    suff2_1 = IsFirstLimitedSuff2_1 z first
    suff2_2 = IsFirstLimitedSuff2_2 z first
    suff2_3 = IsFirstLimitedSuff2_3 z first
    suff2_4 = IsFirstLimitedSuff2_4 z first
    suff2_5 = IsFirstLimitedSuff2_5 z first
    suff2_6 = IsFirstLimitedSuff2_6 z first
    all2    = IsAllLimited02 z suff2_1 suff2_2 suff2_3 suff2_4 suff2_5 suff2_6
    suff3_1 = IsFirstLimitedSuff3_1 z first
    suff3_2 = IsFirstLimitedSuff3_2 z first
    suff3_3 = IsFirstLimitedSuff3_3 z first
    suff3_4 = IsFirstLimitedSuff3_4 z first
    suff3_5 = IsFirstLimitedSuff3_5 z first
    suff3_6 = IsFirstLimitedSuff3_6 z first
    all3    = IsAllLimited03 z suff3_1 suff3_2 suff3_3 suff3_4 suff3_5 suff3_6
    suff4_1 = IsFirstLimitedSuff4_1 z first
    suff4_2 = IsFirstLimitedSuff4_2 z first
    suff4_3 = IsFirstLimitedSuff4_3 z first
    suff4_4 = IsFirstLimitedSuff4_4 z first
    suff4_5 = IsFirstLimitedSuff4_5 z first
    all4    = IsAllLimited04 z suff4_1 suff4_2 suff4_3 suff4_4 suff4_5
    suff5_1 = IsFirstLimitedSuff5_1 z first
    suff5_2 = IsFirstLimitedSuff5_2 z first
    suff5_3 = IsFirstLimitedSuff5_3 z first
    suff5_4 = IsFirstLimitedSuff5_4 z first
    suff5_5 = IsFirstLimitedSuff5_5 z first
    suff5_6 = IsFirstLimitedSuff5_6 z first
    all5    = IsAllLimited05 z suff5_1 suff5_2 suff5_3 suff5_4 suff5_5 suff5_6
    suff6_1 = IsFirstLimitedSuff6_1 z first
    suff6_2 = IsFirstLimitedSuff6_2 z first
    suff6_3 = IsFirstLimitedSuff6_3 z first
    suff6_4 = IsFirstLimitedSuff6_4 z first
    suff6_5 = IsFirstLimitedSuff6_5 z first
    suff6_6 = IsFirstLimitedSuff6_6 z first
    all6    = IsAllLimited06 z suff6_1 suff6_2 suff6_3 suff6_4 suff6_5 suff6_6
    suff7_1 = IsFirstLimitedSuff7_1 z first
    suff7_2 = IsFirstLimitedSuff7_2 z first
    suff7_3 = IsFirstLimitedSuff7_3 z first
    suff7_4 = IsFirstLimitedSuff7_4 z first
    suff7_5 = IsFirstLimitedSuff7_5 z first
    suff7_6 = IsFirstLimitedSuff7_6 z first
    suff7_7 = IsFirstLimitedSuff7_7 z first
    all7    = IsAllLimited07 z suff7_1 suff7_2 suff7_3 suff7_4 suff7_5 suff7_6 suff7_7
    suff8_1 = IsFirstLimitedSuff8_1 z first
    suff8_2 = IsFirstLimitedSuff8_2 z first
    suff8_3 = IsFirstLimitedSuff8_3 z first
    suff8_4 = IsFirstLimitedSuff8_4 z first
    suff8_5 = IsFirstLimitedSuff8_5 z first
    suff8_6 = IsFirstLimitedSuff8_6 z first
    all8    = IsAllLimited08 z suff8_1 suff8_2 suff8_3 suff8_4 suff8_5 suff8_6
  in IsAllLimited01 z IsAllLimited00 all2 all3 all4 all5 all6 all7 all8

-- 最終的な定理
limitedDivSeq : (n : Nat) -> (FirstLimited . B.allDivSeq) n
limitedDivSeq = makeLimitedDivSeq firstToAll


labelWith : Stream labelType -> List a -> List (labelType, a)
labelWith lbs [] = []
labelWith (lbl :: lbs) (val :: vals) = (lbl, val) :: labelWith lbs vals
label : List a -> List (Integer, a)
label = labelWith (iterate (+1) 0)


import Effects
import Effect.StdIO
import Effect.State

-- Local Variables:
-- idris-load-packages: ("contrib" "prelude" "effects" "base")
-- End:

-- this is mostly code from the tutorial on effects
hello : Eff () [STDIO]
hello = putStrLn "hello world!"

data BTree a = Leaf
             | Node (BTree a) a (BTree a)

testTree : BTree String
testTree = Node (Node Leaf "Jim" Leaf)
                "Fred"
                (Node (Node Leaf "Alice" Leaf)
                      "Sheila"
                      (Node Leaf "Bob" Leaf))

treeTagAux : BTree a -> Eff (BTree (Int,a)) [STATE Int]
treeTagAux Leaf = pure Leaf
treeTagAux (Node b1 x b2) = do
                    b1' <- treeTagAux b1
                    i <- get
                    put (i + 1)
                    b2' <- treeTagAux b2
                    pure (Node b1' (i,x) b2')

-- So one of the things that I find super fascinating are the dependent effects
-- obviously such things are needed for the purpose of having things like state that
-- contain dependent types, but it's also just really neat and makes, at least to me,
-- more sense than the simple-type-theory style monadic approach to semantics
-- The way I think I see effects in Idris is that you're essentially creating an internal
-- language of an effect and then you need to give a semantics of the effect in terms of
-- the types that support the operation and *that* is what the handlers are.

-- Let's try making a reader effect, one that has an ask and local operation

data Reader : Effect where
  Ask : Reader a a (\x => a)
  Local : (a -> b) -> Reader c b f -> Reader c a (\x => a)

-- I think that's the right signature, it type checks at least. It's a little more complicated
-- than a normal reader because there could be some kind of dependent type in the reader state
-- such as, I don't know, an environment that's indexed by its length?

-- so what we're trying to do here is
-- run the "local" effect with the resource (f r)
-- get back the value, in this case of type 't' from the local effect action
-- then restore the original state by passing that to the original continuation
-- now where I'm getting stuck, I think, is that, to me, this should clearly be something
-- kinda like
--  handle (f r) loc (\t _ => k t r)

 rhs : (m : Type -> Type) -> (r : res) -> (act : Reader t res resk) -> (k : (x : t) -> resk x -> m a) -> m a
 rhs m r Ask k = k r r
 rhs m r (Local f loc) k = rhs m (f r) loc (\ t,_ => k t r) -- Why did this work but recursion in handle didn't???

 READER : Type -> EFFECT
 READER t = MkEff t Reader -- yeah this part is just like state aren't I clever

instance Handler Reader m where
  handle r act k = rhs m r act k

{-
instance Handler Reader m where
  handle r Ask k = k r r
  handle r (Local f loc) k = handle (f r) loc ?f
-}


data List' a = Nil | Cons a (List' a)

-- Generated with `:gd 4 mapList'`
mapList' : ((1 x : a) -> b) -> (1 xs : List' a) -> List' b
mapList' f [] = []
mapList' f (Cons x y) = Cons (f x) (mapList' f y)

data Tree1 a = Nil1 | Node1 a (Tree1 a) (Tree1 a)

mapTree1 : ((1 x : a) -> b) -> (1 t : Tree1 a) -> Tree1 b

data Tree2 a = Nil2 | Node2 a (List' (Tree2 a))

-- TODO: Fix not entirly appropriate definition (nulls list of Node2)
mapTree2 : ((1 x : a) -> b) -> (1 t : Tree2 a) -> Tree2 b


plus_commutes : (n, m : Nat) -> plus n m = plus m n
plus_assoc : (n, m, p : Nat) -> plus n (plus m p) = plus (plus n m) p


> module SimpleProb.MonadicOperations

> import Data.List
> import Data.List.Quantifiers
> import Syntax.PreorderReasoning

> import SimpleProb.SimpleProb
> import SimpleProb.BasicOperations
> import SimpleProb.BasicProperties
> import NonNegRational.NonNegRational
> import NonNegRational.BasicOperations
> import NonNegRational.BasicProperties
> import Nat.Positive
> import Fraction.Normal
> import Num.Refinements
> import Fun.Operations
> import List.Operations
> import List.Properties
> import Sigma.Sigma

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

* |SimpleProb| is a functor:

> |||
> fmap : {A, B : Type} -> (A -> B) -> SimpleProb A -> SimpleProb B
> fmap f (MkSimpleProb aps s1p) = MkSimpleProb aps' s1p' where
>   aps' : List (B, NonNegRational)
>   aps' = map (cross f id) aps
>   s1p' : sumMapSnd aps' = 1
>   s1p' = trans s1 (trans s2 s3) where
>     s1 : sumMapSnd aps' = sum (map snd aps')
>     s1 = Refl
>     s2 : sum (map snd aps') = sum (map snd aps)
>     s2 = cong (mapSndMapCrossAnyIdLemma f aps)
>     s3 : sum (map snd aps) = 1
>     s3 = s1p
>
> {-
>   s1p' = ( sumMapSnd aps' )
>        ={ Refl }=
>          ( sum (map snd aps') )
>        ={ cong (mapSndMapCrossAnyIdLemma f aps) }=
>          ( sum (map snd aps) )
>        ={ Refl }=
>          ( sumMapSnd aps )
>        ={ s1p }=
>          ( 1 )
>        QED
> -}

* |SimpleProb| is a monad:

> |||
> ret : {A : Type} -> A -> SimpleProb A
> ret {A} a = MkSimpleProb [(a, 1)] (sumMapSndSingletonLemma a 1)

> |||
> bind : {A, B : Type} -> SimpleProb A -> (A -> SimpleProb B) -> SimpleProb B
> bind {A} {B} (MkSimpleProb aps s1p) f = MkSimpleProb bps' s1p' where
>   f' : A -> List (B, NonNegRational)
>   f' a = toList (f a)
>   s1ps' : (a : A) -> sumMapSnd (f' a) = 1
>   s1ps' a = toListLemma (f a)
>   bps' : List (B, NonNegRational)
>   bps' = mvMult aps f'
>   s1p' : sumMapSnd bps' = 1
>   s1p' = ( sumMapSnd bps' )
>        ={ Refl }=
>          ( sumMapSnd (mvMult aps f') )
>        ={ mvMultLemma aps f' s1ps' }=
>          ( sumMapSnd aps )
>        ={ s1p }=
>          ( 1 )
>        QED

* |SimpleProb| is a container monad:

> |||
> Elem : {A : Type} -> A -> SimpleProb A -> Type
> Elem a sp = Elem a (support sp)

> |||
> NonEmpty : {A : Type} -> SimpleProb A -> Type
> NonEmpty sp = List.Operations.NonEmpty (support sp)

> |||
> All : {A : Type} -> (P : A -> Type) -> SimpleProb A -> Type
> All P sp = All P (support sp)

> ||| Tagging
> tagElem  :  {A : Type} -> (sp : SimpleProb A) -> SimpleProb (Sigma A (\ a => a `Elem` sp))
> tagElem sp = MkSimpleProb aps' s1p' where
>     ssp  : List A
>     ssp  = support sp
>     psp  : List NonNegRational
>     psp  = probs sp
>     as'  : List (Sigma A (\ a => a `Elem` sp))
>     as'  = List.Operations.tagElem ssp
>     aps' : List (Sigma A (\ a => a `Elem` sp), NonNegRational)
>     aps' = zip as' psp
>     s1p' : sumMapSnd aps' = 1
>     s1p' = trans s1 (trans s7 s8) where
>       s1 : sumMapSnd aps' = sum (snd (unzip aps'))
>       s1 = sumMapSndUnzipLemma aps'
>       s2 : length as' = length ssp
>       s2 = tagElemPreservesLength ssp
>       s3 : length ssp = length psp
>       s3 = lengthSupportProbsLemma sp
>       s4 : length as' = length psp
>       s4 = trans s2 s3
>       s5 : unzip (zip as' psp) = (as', psp)
>       s5 = unzipZipLemma as' psp s4
>       s6 : snd (unzip aps') = psp
>       s6 = cong {f = snd} s5
>       s7 : sum (snd (unzip aps')) = sum psp
>       s7 = cong {f = sum} s6
>       s8 : sum psp = 1
>       s8 = sumProbsLemma sp

> {-

> ---}


%hide Prelude.integerToNat

data MyNat : Type where
    Z : MyNat
    S : MyNat -> MyNat

%builtin Natural MyNat

integerToMyNat : Integer -> MyNat
integerToMyNat i = if i <= 0
    then Z
    else S $ integerToMyNat (i - 1)

%builtin IntegerToNatural integerToMyNat

natToMyNat : Nat -> MyNat
natToMyNat Z = Z
natToMyNat (S k) = S $ natToMyNat k

%builtin IntegerToNatural natToMyNat

integerToNotNat : Integer -> Maybe String
integerToNotNat x = Just "Boo"

%builtin IntegerToNatural integerToNotNat


= The First Tale

> module WhoStoleTheTarts.TheFirstTale
>
> %access  export
> %default total
>
> %hide Prelude.Pairs.DPair.fst

Someone stole the jam. Our job is to figure out who the thief was.

== Suspects

We know it was one of the

- March Hare,

> data MarchHare

- Mad Hatter, or

> data MadHatter

- Dormouse

> data Dormouse

... and that they worked alone.

> SomeoneStoleTheJam : Type
> SomeoneStoleTheJam = Either (    MarchHare, Not MadHatter, Not Dormouse)
>                    $ Either (Not MarchHare,     MadHatter, Not Dormouse)
>                             (Not MarchHare, Not MadHatter,     Dormouse)

== Statements

The March Hare claims,

I never stole the jam!

> MarchHareStatement : (truth : Bool) -> Type
> MarchHareStatement False =     MarchHare
> MarchHareStatement True  = Not MarchHare

According to the Mad Hatter,

One of us stole it, but it wasn't me!

> MadHatterStatement : (truth : Bool) -> Type
> MadHatterStatement False = (    MadHatter, Not    MarchHare, Not Dormouse)
> MadHatterStatement True  = (Not MadHatter, Either MarchHare      Dormouse)

As per the Dormouse,

At least one of them (spoke the truth).

> DormouseStatement : (truth : Bool) -> Type
> DormouseStatement False =     (MarchHareStatement False, MadHatterStatement False)
> DormouseStatement True  = Not (MarchHareStatement False, MadHatterStatement False)

== Revelation

We're also given a revelation:

> Revelation : Type

The March Hare and the Dormouse were not both speaking the truth, i.e. either

- ... the March Hare spoke the truth and the Dormouse did not

> Revelation = Either (MarchHareStatement True,  DormouseStatement False)

- ... or the March Hare did not speak the truth and the Dormouse did.

>                     (MarchHareStatement False, DormouseStatement True)

== Conclusion

Given the [statements](#statements) above and the [revelation](#revelation),

> Thief : SomeoneStoleTheJam -> Revelation

... we can conclude the March Hare stole the jam.

>      -> (MarchHare, Not MadHatter, Not Dormouse)

The first clause is a simple pattern match.

> Thief (Left  marchHare)         _                        = marchHare

From the revelation it follows that if the March Hare spoke the truth,
then the Dormouse lied. If the March Hare spoke the truth, then they
didn't steal the jam. But if the Dormouse lied, then so did the March Hare
and is guilty *BWOC*.

> Thief _                         (Left  (itWas,(them,_))) = absurd (itWas them)

If the March Hare lied, then they stole the jam.

> Thief (Left  (_,did,it))        (Right (marchHare,_))    = (marchHare,did,it)

If we assume the Mad Hatter stole jam and the March Hare lied,
then the March Hare did it *BWOC*.

> Thief (Right (Left  (itWas,_))) (Right (them,_))         = absurd (itWas them)

Assume the Dormouse did it and lied. If the Dormouse lied,
then the March Hare lied, and therefore stole the jam.

> Thief (Right (Right (itWas,_))) (Left  (_,(them,_)))     = absurd (itWas them)

Assume the Dormouse did it and the March Hare lied.
If the March Hare lied then they are guilty.

> Thief (Right (Right (itWas,_))) (Right (them,_))         = absurd (itWas them)

∎


module Main

import Data.Vect

infixr 5 .+.

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

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

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

-- search : (store : DataStore) -> String -> List String
-- search (MkData _ items) q = filter (isInfixOf q) (toList items)

-- search' : (store : DataStore) -> String -> List (Nat, String)
-- search' (MkData size items) q
--   = filter ((isInfixOf q) . snd)
--            (zip (enumFromTo 0 size) (toList items))

addToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore
addToStore (MkData schema size items) item = MkData schema _ (addToData items)
  where
    addToData : Vect old (SchemaType schema) -> Vect (S old) (SchemaType schema)
    addToData [] = [item]
    addToData (x :: xs) = x :: addToData xs

-- sumInputs : Integer -> String -> Maybe (String, Integer)
-- sumInputs sum input
--   = let val = cast input in
--         if val < 0
--         then Nothing
--         else let newVal = sum + val in
--                  Just ("Subtotal: " ++ show newVal ++ "\n", newVal)

data Command : Schema -> Type where
  SetSchema : (new : Schema) -> Command schema
  Add : SchemaType schema -> Command schema
  Get : Integer -> Command schema
  GetAll : Command schema
  Search : String -> Command schema
  Size : Command schema
  Quit : Command schema

mutual
  parseSchema : List String -> Maybe Schema
  parseSchema ("String" :: xs) = doParseSchema xs SString
  parseSchema ("Int" :: xs) = doParseSchema xs SInt
  parseSchema ("Char" :: xs) = doParseSchema xs SChar
  parseSchema _ = Nothing

  doParseSchema : List String -> Schema -> Maybe Schema
  doParseSchema [] type = Just type
  doParseSchema xs type = do
    xs' <- parseSchema xs
    pure (type .+. xs')

setSchema : (store : DataStore) -> Schema -> Maybe DataStore
setSchema store schema =
  case size store of
       Z => Just (MkData schema _ [])
       (S k) => Nothing

parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)
parsePrefix SString input = getQuoted (unpack input)
  where
    getQuoted : List Char -> Maybe (String, String)
    getQuoted ('"' :: xs) =
      case span (/= '"') xs of
        (quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest))
        _ => Nothing
    getQuoted _ = Nothing
parsePrefix SInt input = case span isDigit input of
                             ("", rest) => Nothing
                             (num, rest) => Just (cast num, ltrim rest)
parsePrefix SChar input = getQuoted (unpack input)
  where
    getQuoted : List Char -> Maybe (Char, String)
    getQuoted ('\'' :: c :: '\'' :: rest) = Just (c, ltrim (pack rest))
    getQuoted ('\'' :: '\\' :: '\'' :: '\'' :: rest) = Just ('\'', ltrim (pack rest))
    getQuoted _ = Nothing
parsePrefix (lft .+. rgt) input = do
  (l, input') <- parsePrefix lft input
  (r, input'') <- parsePrefix rgt input'
  pure ((l, r), input'')

parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)
parseBySchema schema input = do
  (res, "") <- parsePrefix schema input | _ => Nothing
  pure res

parseCommand : (schema : Schema) -> (cmd : String) -> (args : String) -> Maybe (Command schema)
parseCommand schema "add" str = Add <$> parseBySchema schema str
parseCommand schema "get" "" = Just GetAll
parseCommand schema "get" val =
  case all isDigit (unpack val) of
       False => Nothing
       True => Just (Get (cast val))
parseCommand schema "search" query = Just (Search query)
parseCommand schema "size" "" = Just Size
parseCommand schema "quit" "" = Just Quit
parseCommand schema "schema" str = SetSchema <$> parseSchema (words str)
parseCommand _ _ _ = Nothing

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

display : (SchemaType schema) -> String
display {schema = SString} item = show item
display {schema = SInt} item = show item
display {schema = SChar} item = show item
display {schema = (_ .+. _)} (l, r) = (display l) ++ ", " ++ (display r)

showStore : DataStore -> String
showStore store = showItems (items store)
  where
    showItems : Vect size (SchemaType schema) -> String
    showItems = concat . map (\x => display x ++ "\n")

getEntry : (store : DataStore) -> (id : Integer) -> Maybe String
getEntry store id = do
  id' <- integerToFin id (size store)
  pure (display (index id' (items store)))

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
  = case parse (schema store) input of
         Nothing => Just ("Invalid command\n", store)
         Just cmd => processCommand cmd
  where
    processCommand : (cmd : Command (schema store)) -> Maybe (String, DataStore)
    processCommand (Add item)
      = Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
    processCommand (Get id) = case getEntry store id of
                                         Just item => Just (item ++ "\n", store)
                                         Nothing => Just ("Out of range\n", store)
    processCommand GetAll = Just (showStore store, store)
    -- processCommand (Search query)
    --   = let results = search' store query
    --         results' = map (\(k, v) => show k ++ ": " ++ v) results in
    --         Just (unlines results' ++ "\n", store)
    processCommand Size = Just ("Size: " ++ show (size store) ++ "\n", store)
    processCommand (SetSchema schema') =
      case setSchema store schema' of
           Nothing => Just ("Can't update schema\n", store)
           Just store' => Just ("OK\n", store')
    processCommand Quit = Nothing

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


module Main

%default total

%logging "declare.data.parameters" 20
%logging "eval.eta" 10

-- explicit
data Value : (value : Nat -> Type) -> Type where
  EmptyV : {0 value : Nat -> Type} -> Value (\ n => value n)

data TValue : Nat -> Type where
  MkTupleV : Value (\n => TValue n) -> TValue n


module RegExp.Types

import Data.List
import Decidable.Equality

||| A regular expression specification.
public export
data RegExp : (0 a : Type) -> Type where
  ||| Denotes the empty set
  Null : RegExp a
  ||| Denotes the empty string
  Empty : RegExp a
  ||| Denotes a single literal character
  Lit : a -> RegExp a
  ||| Denotes concatenation
  Cat : RegExp a -> RegExp a -> RegExp a
  ||| Denotes disjunction (OR)
  Disj : RegExp a -> RegExp a -> RegExp a
  ||| Denotes conjunction (AND)
  Conj : RegExp a -> RegExp a -> RegExp a
  ||| Denotes the Kleene star
  Star : RegExp a -> RegExp a

||| The property of a regular expression matching an input string.
public export
data Matches: RegExp a -> List a -> Type where
  ||| Rule: `[]` is in `Empty`
  InEmpty : Matches Empty []
  ||| Rule: `[x]` is in `Lit x`
  InLit : {x : a} -> Matches (Lit x) [x]
  ||| Rule: If `xs` is in regular expressions `r` and `ys` is in regular expression `s`, then
  ||| `xs ++ ys` is in `Cat r s`
  InCat : {xs : List a} ->
          {ys : List a} ->
          {zs : List a} ->
          {r : RegExp a} ->
          {s : RegExp a} ->
          (p : zs = xs ++ ys) ->
          Matches r xs ->
          Matches s ys ->
          Matches (Cat r s) zs
  ||| Rule: If `xs` is in regular expression `r`, then `xs` is in `Disj r _` (i.e. left side)
  InDisjL : {xs : List a} ->
            {r : RegExp a} ->
            {s : RegExp a} ->
            Matches r xs ->
            Matches (Disj r s) xs
  ||| Rule: If `xs` is in regular expression `s`, then `xs` is in `Disj _ s` (i.e. right side)
  InDisjR : {xs : List a} ->
            {r : RegExp a} ->
            {s: RegExp a} ->
            Matches s xs ->
            Matches (Disj r s) xs
  ||| Rule: If `xs` is in regular expressions `r` and `s`, then `xs` is in `Conj r s`
  InConj : {xs : List a} ->
           {r : RegExp a} ->
           {s : RegExp a} ->
           Matches r xs ->
           Matches s xs ->
           Matches (Conj r s) xs
  ||| Rule: For all regular expression `r`, the empty string is in `Star r`.
  InStarZ : {r: RegExp a} ->
            Matches (Star r) []
  ||| Rule: If `xs` is in regular expression `r` and `ys` is in `Star r`, then `xs ++ ys` is also
  ||| in `Star r`.
  InStarS : {xs : List a} ->
            {ys : List a} ->
            {zs : List a} ->
            {r : RegExp a} ->
            (p : zs = xs ++ ys) ->
            Matches r xs ->
            Matches (Star r) ys ->
            Matches (Star r) (xs ++ ys)

export
Uninhabited (Matches Null xs) where
  uninhabited _ impossible

export
Uninhabited (Matches Empty (x::xs)) where
  uninhabited _ impossible

export
Uninhabited (Matches (Lit x) []) where
  uninhabited _ impossible

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

export
DecEq a => DecEq (RegExp a) where
  decEq Null Null = Yes Refl
  decEq (Lit x) (Lit y) with (decEq x y)
    decEq (Lit x) (Lit x) | (Yes Refl)  = Yes Refl
    decEq (Lit x) (Lit y) | (No contra) = No $ \p => case p of
                                                     Refl => contra Refl
  decEq (Cat r s) (Cat t u) with (decEq r t)
    decEq (Cat r s) (Cat r u) | (Yes Refl) with (decEq s u)
      decEq (Cat r s) (Cat r s) | (Yes Refl) | (Yes Refl) = Yes Refl
      decEq (Cat r s) (Cat r u) | (Yes Refl) | (No contra) = No $ \p => case p of
                                                                             Refl => contra Refl
    decEq (Cat r s) (Cat t u) | (No contra) = No \p => case p of
                                                            Refl => contra Refl
  decEq (Disj r s) (Disj t u) with (decEq r t)
    decEq (Disj r s) (Disj r u) | (Yes Refl) with (decEq s u)
      decEq (Disj r s) (Disj r s) | (Yes Refl) | (Yes Refl)  = Yes Refl
      decEq (Disj r s) (Disj r u) | (Yes Refl) | (No contra) = No $ \p => case p of
                                                                               Refl => contra Refl
    decEq (Disj r s) (Disj t u) | (No contra) = No $ \p => case p of
                                                                Refl => contra Refl
  decEq (Conj r s) (Conj t u) with (decEq r t)
    decEq (Conj r s) (Conj r u) | (Yes Refl) with (decEq s u)
      decEq (Conj r s) (Conj r s) | (Yes Refl) | (Yes Refl)  = Yes Refl
      decEq (Conj r s) (Conj r u) | (Yes Refl) | (No contra) = No $ \p => case p of
                                                                               Refl => contra Refl
    decEq (Conj r s) (Conj t u) | (No contra) = No $ \p => case p of
                                                                Refl => contra Refl
  decEq (Star r) (Star s) with (decEq r s)
    decEq (Star r) (Star r) | (Yes Refl) = Yes Refl
    decEq (Star r) (Star s) | (No contra) = No $ \p => case p of
                                                            Refl => contra Refl
  -- This is plain old structural equality, so I figure it's better to use a `believe_me` catch-all
  -- than to write out a million trivial `No` cases.
  decEq _ _ = No believe_me

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

||| Proof that if the result of a concatenation is empty, then both inputs are empty
appendOutputNil : {xs : List a} ->
                  {ys : List a} ->
                  xs ++ ys = [] ->
                  (xs = [], ys = [])
appendOutputNil {xs=[]} {ys=[]}    p = (Refl, Refl)
appendOutputNil {xs=[]} {ys=y::ys} p = absurd p
appendOutputNil {xs=(x::xs)} {ys}  p = absurd p

||| Proof that if an `Empty` regular expression matches a string, then the string is empty.
export
emptyMatch_implies_emptyList : Matches Empty xs -> xs = []
emptyMatch_implies_emptyList InEmpty = Refl

||| Proof that for all `Lit x` matches, `x` is equal to the head of the string.
export
litMatches_implies_headEqual : DecEq a =>
                               {x : a} ->
                               {y : a} ->
                               {ys : List a} ->
                               Matches (Lit x) (y::ys) ->
                               x = y
litMatches_implies_headEqual {x} {y=x} {ys=[]} InLit = Refl

||| Proof that if `Lit` matches `x::xs`, then `xs = []`
export
litMatchesCons_implies_restEmpty : Matches (Lit x) (x::xs) -> xs = []
litMatchesCons_implies_restEmpty InLit = Refl

||| Proof that if the `Cat r s` matches empty, then both `r` and `s` also match empty
export
catNotEmpty : {r : RegExp a} ->
              {s : RegExp a} ->
              Matches (Cat r s) [] ->
              (Matches r [], Matches s [])
catNotEmpty (InCat p r s) with (appendOutputNil $ sym p)
  catNotEmpty (InCat p r s) | (Refl, Refl) = (r, s)

||| Proof that if `Disj r s` matches empty, then at least one of `r` and `s` matches empty
export
disjNotEmpty : {r : RegExp a} ->
               {s : RegExp a} ->
               Matches (Disj r s) [] ->
               Either (Matches r []) (Matches s [])
disjNotEmpty (InDisjL r) = Left r
disjNotEmpty (InDisjR r) = Right r

||| Proof that if the `Conj r s` matches empty, then both `r` and `s` also match empty
export
conjNotEmpty : {r : RegExp a} ->
               {s : RegExp a} ->
               Matches (Conj r s) [] ->
               (Matches r [], Matches s [])
conjNotEmpty (InConj r s) = (r, s)


module G4LowerFormalPSpring

%access public export
%default total

-- 形式的体系P
-- 数項化された自然数
GNat : Type
GNat = Nat

-- 10.6.1 基本記号のゲーデル数
左かっこ : GNat
左かっこ = 11
右かっこ : GNat
右かっこ = 13