module HEff

-- Based on https://github.com/effectfully/Eff/blob/master/Resources/Core.agda

import Data.HVect

Effect : Type -> Type
Effect r = r -> (a : Type) -> (a -> r) -> Type

Effects : (Type -> Type) -> Vect n Type -> Vect n Type
Effects f [] = []
Effects f (x :: xs) = f x :: Effects f xs

data Exists' : {t : Type} -> {rs : Vect n Type} ->
               HVect rs -> t -> HVect (Effects Effect rs) -> Effect t -> Type where
  Here : Exists' (x :: xs) x (y :: ys) y
  There : Exists' xs x ys y -> Exists' (_ :: xs) x (_ :: ys) y

update' : {t : Type} -> (r : HVect rs) -> (e : Exists' {t = t} r s effs eff) -> t -> HVect rs
update' [] Here _ impossible
update' [] (There _) _ impossible
update' (x :: xs) Here v = v :: xs
update' (x :: xs) (There e) v = x :: update' xs e v

HEffect : Type
HEffect = {n : Nat} -> (rs : Vect n Type) -> HVect (Effects Effect rs) -> Effect (HVect rs)

data HEff : HEffect where
  Pure : (x : a) -> HEff rs effs (r' x) a r'
  Bind : (e : Exists' r s effs eff) ->
          eff s a s' ->
          ((x : a) -> HEff rs effs (update' r e (s' x)) b r'') -> HEff rs effs r b r''

(>>=) : HEff rs effs r a r' -> ((x : a) -> HEff rs effs (r' x) b r'') -> HEff rs effs r b r''
(>>=) (Pure x) f = f x
(>>=) (Bind e x f) g = Bind e x (\y => f y >>= g)

data Access = LoggedOut | LoggedIn
data Store : Access -> (ty : Type) -> (ty -> Access) -> Type where
  Login : Store LoggedOut () (const LoggedIn)
  Logout : Store LoggedIn () (const LoggedOut)

login : {auto e : Exists' r LoggedOut effs Store} ->
         HEff rs effs r () (\_ => update' r e LoggedIn)
login {e} = Bind e Login Pure

logout : {auto e : Exists' r LoggedIn effs Store} ->
         HEff rs effs r () (\_ => update' r e LoggedOut)
logout {e} = Bind e Logout Pure

data State : Type -> (a : Type) -> (a -> Type) -> Type where
  Get : State s s (const s)
  Put : s' -> State s () (const s')

get : {auto e : Exists' r s effs State} ->
      HEff rs effs r s (\_ => update' r e s)
get {e} = Bind e Get Pure

put : {auto e : Exists' r s effs State} -> s' ->
      HEff rs effs r () (\_ => update' r e s')
put {e} s' = Bind  e (Put s') Pure

run : HEff [] [] r a r' -> a
run (Pure x) = x
run (Bind Here _ _) impossible
run (Bind (There _) _ _) impossible

head' : HVect xs -> head xs
head' (x :: _) = x
tail' : HVect xs -> HVect (tail xs)
tail' (x :: xs) = xs

runStore : HEff (Access :: rs) (Store :: effs) r a r' -> HEff rs effs (tail' r) a (\x => tail' $ r' x)
runStore (Pure x) = Pure x
runStore (Bind Here Login f) = runStore $ f ()
runStore (Bind Here Logout f) = runStore $ f ()
runStore (Bind (There e) eff f) = Bind e eff (\x => runStore $ f x)

runState : (head' r) -> HEff (Type :: rs) (State :: effs) r a r' ->  HEff rs effs (tail' r) (DPair a (\x => head' $ r' x)) (\x => tail' $ r' (fst x))
runState s (Pure x) = Pure (x ** s)
runState s (Bind Here Get f) = runState s $ f s
runState s (Bind Here (Put s') f) = runState s' $ f ()
runState s (Bind (There e) eff f) = Bind e eff (\x => runState s $ f x)

example : HEff [Access, Type] [Store, State] [LoggedOut, Nat] Nat (\n => [LoggedOut, Vect n Bool])
example = do login
             n <- get
             put (replicate n True)
             logout
             Pure n

test : DPair Nat (\n => Vect n Bool)
test = run . runState 3 . runStore $ example


import Data.Vect

data VectN : Type -> Type where
     MkVectN : (n : Nat) -> Vect n a -> VectN a

doSearch : Nat -> VectN Int
doSearch n = MkVectN ?vlength [1,2,3,4]


module Circuits.NetList.Linear.Usage.DataType.Use.Full

import Decidable.Equality

import Data.Nat
import Data.List.Elem
import Data.List.Quantifiers

import Data.Vect
import Data.Vect.AtIndex
import Data.Vect.Quantifiers

import Data.String

import Toolkit.Data.Whole
import Toolkit.Data.DList
import Toolkit.Data.DList.Elem

import Toolkit.Data.Vect.Extra

import Circuits.Common
import Circuits.NetList.Types
import Circuits.NetList.Linear.Usage.DataType

%default total

mutual
  public export
  data Use : (type : DType)
          -> (free : Usage  type)
          -> (this : IsFree type free)
          -> (used : Usage  type)
          -> (that : IsUsed type used)
                  -> Type
    where
      UFL : Use LOGIC (Logic FREE) FreeL
                      (Logic USED) UsedL

      UFA : (prf : Use type fs free us used)
                -> Use (BVECT (W (S n) ItIsSucc) type) (Array fs) (FreeA free)
                                                       (Array us) (UsedA used)

  public export
  data Result : (type : DType)
             -> (free : Usage type)
             -> (prf  : IsFree type free)
                     -> Type
    where
      R : (u      : Usage type)
       -> (used   : IsUsed type u)
       -> (result : Use    type f free u used)
                 -> Result type f free

  namespace Vect
    public export
    data Use : (type : DType)
            -> (this : Vect n (Usage type))
            -> (free : All (IsFree type) this)
            -> (that : Vect n (Usage type))
            -> (used : All (IsUsed type) that)
                    -> Type
      where
        End : Use type Nil Nil Nil Nil
        Ext : Use type  f       pf        u       pu
           -> Use type     fs       pfs      us       pus
           -> Use type (f::fs) (pf::pfs) (u::us) (pu::pus)

    public export
    data Result : (type : DType)
               -> (free : Vect n (Usage type))
               -> (prf  : All (IsFree type) free)
                       -> Type
      where
        R : {this    : Vect n (Usage type)}
         -> (free    : All (IsFree type) this)
         -> (us      : Vect n (Usage type))
         -> (useds   : All (IsUsed type) us)
         -> (results : Use    type this free us useds)
                    -> Result type this free

mutual

  export
  use : {type : DType}
     -> {free : Usage type}
     -> (prf  : IsFree type free)
             -> Result type free prf
  use FreeL
    = R (Logic USED) UsedL UFL

  use (FreeA prf) with (use prf)
    use (FreeA prf) | (R prf us useds results)
      = R (Array us) (UsedA useds) (UFA results)

  namespace Vect
    export
    use : {type : DType}
       -> {free : Vect n (Usage type)}
       -> (prf  : All (IsFree type) free)
               -> Result type free prf
    use []
      = R [] [] [] End

    use (x :: xs) with (use x)
      use (x :: xs) | (R u used result) with (use xs)
        use (x :: xs) | (R u used result) | (R xs us useds results)
          = R (x :: xs) (u :: us) (used :: useds) (Ext result results)

-- [ EOF ]


module IR.Lens

import Control.Category

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

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

class 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

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

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

instance 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.
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)

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

instance 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

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


module Collections.Util.Bnd

import Decidable.Equality
import Control.Relation
import Control.Order
import Decidable.Order.Strict

||| Extends a type with `Bot` and `Top` values, making it a "bounded" type.
|||
||| Used for orderings in order to allow a value which precedes all other values (`Bot`), and a
||| value which follows all other values (`Top`).
public export
data Bnd : (0 a : Type) -> Type where
  Bot : Bnd a
  Mid : (x : a) -> Bnd a
  Top : Bnd a

export
Uninhabited (Bot = Mid x) where
  uninhabited Refl impossible

export
Uninhabited (Bot = Top) where
  uninhabited Refl impossible

export
Uninhabited (Mid x = Bot) where
  uninhabited Refl impossible

export
Uninhabited (Mid x = Top) where
  uninhabited Refl impossible

export
Uninhabited (Top = Bot) where
  uninhabited Refl impossible

export
Uninhabited (Top = Mid x) where
  uninhabited Refl impossible

||| Proof that if two `Mid` values are equal, then their wrapped values are equal
export
midEq : Mid x = Mid y -> x = y
midEq Refl = Refl

||| Proof that if two `Mid` values are not equal, then their wrapped values are not equal
export
midNotEq : Not (Mid x = Mid y) -> Not (x = y)
midNotEq ctra prf = ctra $ cong Mid prf

export
DecEq t => DecEq (Bnd t) where
  decEq Bot     Bot     = Yes Refl
  decEq Bot     (Mid _) = No absurd
  decEq Bot     Top     = No absurd
  decEq (Mid _) Bot     = No absurd
  decEq (Mid x) (Mid y) = case decEq x y of
                               Yes prf => Yes $ cong Mid prf
                               No ctra => No $ ctra . midEq
  decEq (Mid x) Top     = No absurd
  decEq Top     Bot     = No absurd
  decEq Top     (Mid _) = No absurd
  decEq Top     Top     = Yes Refl

||| Given a LTE (less than or equal) relation on `a`, produces an LTE relation extended to `Bnd a`
|||
||| @ o The ordering to extend
public export
data BndLTE : (o : a -> a -> Type) -> Bnd a -> Bnd a -> Type where
  ||| `Bot` is less than or equal to everything
  BotLTEAll : BndLTE o Bot y
  ||| Two `Mid`s are ordered iff their wrapped values are ordered
  MidLTEMid : {0 o : a -> a -> Type} -> o x y -> BndLTE o (Mid x) (Mid y)
  ||| Everything is less than or equal to `Top`
  AllLTETop : BndLTE o x Top

export
Reflexive ty rel => Reflexive (Bnd ty) (BndLTE rel) where
  reflexive {x=Bot}   = BotLTEAll
  reflexive {x=Mid x} = MidLTEMid $ reflexive {x=x}
  reflexive {x=Top}   = AllLTETop

export
Transitive ty rel => Transitive (Bnd ty) (BndLTE rel) where
  transitive {x=Bot}                       BotLTEAll      yz             = BotLTEAll
  transitive {x=Mid x} {y=Mid y} {z=Mid z} (MidLTEMid xy) (MidLTEMid yz) = MidLTEMid $ transitive {x} {y} {z} xy yz
  transitive {x=Mid _} {y=Mid _} {z=Top}   (MidLTEMid xy) AllLTETop      = AllLTETop
  transitive           {y=Top}   {z=Top}   AllLTETop      AllLTETop      = AllLTETop

export
Antisymmetric ty rel => Antisymmetric (Bnd ty) (BndLTE rel) where
  antisymmetric {x=Bot}   {y=Bot}   BotLTEAll      BotLTEAll      = Refl
  antisymmetric {x=Mid x} {y=Mid y} (MidLTEMid xy) (MidLTEMid yx) = cong Mid $ antisymmetric {x} {y} xy yx
  antisymmetric {x=Top}   {y=Top}   AllLTETop      AllLTETop      = Refl

export
Connex ty rel => Connex (Bnd ty) (BndLTE rel) where
  connex {x=Bot}             _   = Left BotLTEAll
  connex           {y=Bot}   _   = Right BotLTEAll
  connex {x=Top}             _   = Right AllLTETop
  connex           {y=Top}   _   = Left AllLTETop
  connex {x=Mid x} {y=Mid y} prf = case connex {rel} {x} {y} (midNotEq prf) of
                                        Left  xy => Left  $ MidLTEMid xy
                                        Right yx => Right $ MidLTEMid yx

||| Given a LT (less than) relation on `a`, produces a LT relation extended to `Bnd a`
|||
||| @ so The strict ordering to extend
public export
data BndLT : (so : a -> a -> Type) -> Bnd a -> Bnd a -> Type where
  BotLTMid : BndLT so Bot (Mid x)
  BotLTTop : BndLT so Bot Top
  MidLTMid : {0 so : a -> a -> Type} -> so x y -> BndLT so (Mid x) (Mid y)
  MidLTTop : BndLT so (Mid x) Top

export
Transitive ty rel => Transitive (Bnd ty) (BndLT rel) where
  transitive {x=Bot}   {y=Mid _} {z=Mid _} BotLTMid      (MidLTMid _)  = BotLTMid
  transitive {x=Bot}   {y=Mid _} {z=Top}   BotLTMid      MidLTTop      = BotLTTop
  transitive {x=Bot}   {y=Top}             BotLTTop      BotLTMid      impossible
  transitive {x=Bot}   {y=Top}             BotLTTop      BotLTTop      impossible
  transitive {x=Bot}   {y=Top}             BotLTTop      (MidLTMid x)  impossible
  transitive {x=Bot}   {y=Top}             BotLTTop      MidLTTop      impossible
  transitive {x=Mid x} {y=Mid y} {z=Mid z} (MidLTMid xy) (MidLTMid yz) = MidLTMid $ transitive {x} {y} {z} xy yz
  transitive {x=Mid x} {y=Mid y} {z=Top}   (MidLTMid w)  MidLTTop      = MidLTTop
  transitive {x=Mid _} {y=Top}             MidLTTop      BotLTMid      impossible
  transitive {x=Mid _} {y=Top}             MidLTTop      BotLTTop      impossible
  transitive {x=Mid _} {y=Top}             MidLTTop      (MidLTMid y)  impossible
  transitive {x=Mid _} {y=Top}             MidLTTop      MidLTTop      impossible

export
Irreflexive ty rel => Irreflexive (Bnd ty) (BndLT rel) where
  irreflexive {x=Mid x} (MidLTMid xx) = irreflexive {x} xx

export
Asymmetric ty rel => Asymmetric (Bnd ty) (BndLT rel) where
  asymmetric BotLTMid BotLTMid impossible
  asymmetric BotLTMid BotLTTop impossible
  asymmetric BotLTMid (MidLTMid _) impossible
  asymmetric BotLTMid MidLTTop impossible
  asymmetric BotLTTop BotLTMid impossible
  asymmetric BotLTTop BotLTTop impossible
  asymmetric BotLTTop (MidLTMid _) impossible
  asymmetric BotLTTop MidLTTop impossible
  asymmetric (MidLTMid xy) (MidLTMid yx) = asymmetric {rel} xy yx
  asymmetric MidLTTop BotLTMid impossible
  asymmetric MidLTTop BotLTTop impossible
  asymmetric MidLTTop (MidLTMid _) impossible
  asymmetric MidLTTop MidLTTop impossible

export
StrictPreorder ty rel => StrictPreorder (Bnd ty) (BndLT rel) where

export
StrictOrdered ty rel => StrictOrdered (Bnd ty) (BndLT rel) where
  order Bot     Bot     = DecEQ Refl
  order Bot     (Mid _) = DecLT BotLTMid
  order Bot     Top     = DecLT BotLTTop
  order (Mid _) Bot     = DecGT BotLTMid
  order (Mid x) (Mid y) = case order x y of
                               DecLT xy => DecLT $ MidLTMid xy
                               DecEQ prf => DecEQ $ cong Mid prf
                               DecGT yx => DecGT $ MidLTMid yx
  order (Mid _) Top     = DecLT MidLTTop
  order Top     Bot     = DecGT BotLTTop
  order Top     (Mid _) = DecGT MidLTTop
  order Top     Top     = DecEQ Refl


module HoareAsLogic

import Assn
import Expr
import Equiv
import Hoare
import Imp
import Logic
import Maps

%access public export

%default total

data HoareProof : Assertion -> Com -> Assertion -> Type where
  H_Skip : HoareProof p SKIP p
  H_Ass : HoareProof (AssignSub x a q) (x ::= a) q
  H_Seq : HoareProof p c q -> HoareProof q d r ->
          HoareProof p (do c; d) r
  H_If : HoareProof (\st => (p st, BAssn b st)) c1 q ->
         HoareProof (\st => (p st, Not (BAssn b st))) c2 q ->
         HoareProof p (CIf b c1 c2) q
  H_If1 : HoareProof (\st => (p st, BAssn b st)) c q ->
          (\st => (p st, Not (BAssn b st))) ->> q ->
          HoareProof p (CIf1 b c) q
  H_While : HoareProof (\st => (p st, BAssn b st)) c p ->
            HoareProof p (CWhile b c) (\st => (p st, Not (BAssn b st)))
  H_For : HoareProof p init q ->
          HoareProof (\st => (q st, BAssn cond st)) (do body; updt) q ->
          HoareProof p (CFor init cond updt body)
                       (\st => (q st, Not (BAssn cond st)))
  H_Repeat : HoareProof p c q -> (\st => (q st, Not (BAssn b st))) ->> p ->
             HoareProof p (CRepeat c b) (\st => (q st, BAssn b st))
  H_Consequence : HoareProof p' c q' -> (p ->> p') -> (q' ->> q) ->
                  HoareProof p c q

h_consequence_pre : HoareProof p' c q -> (p ->> p') -> HoareProof p c q
h_consequence_pre hp imp = H_Consequence hp imp assertImpliesRefl

h_consequence_post : HoareProof p c q' -> (q' ->> q) -> HoareProof p c q
h_consequence_post hp imp = H_Consequence hp assertImpliesRefl imp

sample_proof : HoareProof
                 (AssignSub X (X + 1) (AssignSub X (X + 2) (\st => st X = 3)))
                 (do X ::= X + 1; X ::= X + 2)
                 (\st => st X = 3)
sample_proof = H_Seq H_Ass H_Ass

hoare_proof_sound : HoareProof p c q -> HoareTriple p c q
hoare_proof_sound {q} H_Skip = hoare_skip q
hoare_proof_sound (H_Ass {q}) = hoare_assign q
hoare_proof_sound (H_Seq {p} {q} {r} hp1 hp2) =
  hoare_seq p q r (hoare_proof_sound hp2) (hoare_proof_sound hp1)
hoare_proof_sound (H_If {p} {q} {b} hpt hpf) =
  hoare_if p q (hoare_proof_sound hpt) (hoare_proof_sound hpf)
hoare_proof_sound (H_If1 {p} {q} hp imp) =
  hoare_if1 p q (hoare_proof_sound hp) imp
hoare_proof_sound (H_While {p} {b} hp) =
  hoare_while p (hoare_proof_sound hp)
hoare_proof_sound (H_For {p} {q} hp_init hp_body_updt) =
  hoare_for p q (hoare_proof_sound hp_init) (hoare_proof_sound hp_body_updt)
hoare_proof_sound (H_Repeat {p} {q} hp imp) =
  hoare_repeat p q (hoare_proof_sound hp) imp
hoare_proof_sound (H_Consequence {p} {q} {p'} {q'} hp p_imp q_imp) =
  hoare_consequence p p' q q' (hoare_proof_sound hp) p_imp q_imp

h_post_true_deriv : HoareProof p c (const ())
h_post_true_deriv {c = CSkip} = h_consequence_pre H_Skip (\_, _ => ())
h_post_true_deriv {c = (CAss _ _)} = h_consequence_pre H_Ass (\_, _ => ())
h_post_true_deriv {p} {c = (CSeq c1 c2)} =
  H_Seq (h_post_true_deriv {p=p} {c=c1}) (h_post_true_deriv {c=c2})
h_post_true_deriv {c = (CIf _ c1 c2)} =
  H_If (h_post_true_deriv {c=c1}) (h_post_true_deriv {c=c2})
h_post_true_deriv {c = (CIf1 _ c)} =
  H_If1 (h_post_true_deriv {c=c}) (\_, _ => ())
h_post_true_deriv {c = (CWhile _ c)} =
  H_Consequence (H_While {p=const ()} (h_post_true_deriv {c=c}))
                (\_, _ => ())
                (\_, _ => ())
h_post_true_deriv {p} {c = f@(CFor init _ updt body)} =
  h_consequence_post
    (H_For (h_post_true_deriv {p=p} {c=init})
           (h_post_true_deriv {c=assert_smaller f (do body; updt)}))
    (\_, _ => ())
h_post_true_deriv {c = (CRepeat c _)} =
  H_Consequence (H_Repeat (h_post_true_deriv {c=c}) (\_, _ => ()))
                (\_, _ => ())
                (\_, _ => ())

h_pre_false_deriv : HoareProof (const Void) c q
h_pre_false_deriv {c = CSkip} = h_consequence_pre H_Skip (\_, v => absurd v)
h_pre_false_deriv {c = (CAss x e)} = h_consequence_pre H_Ass (\_, v => absurd v)
h_pre_false_deriv {c = (CSeq c1 c2)} = H_Seq (h_pre_false_deriv {c=c1})
                                             (h_pre_false_deriv {c=c2})
h_pre_false_deriv {c = (CIf _ ct cf)} =
  H_If (h_consequence_pre (h_pre_false_deriv {c=ct}) (\_, (v, _) => v))
       (h_consequence_pre (h_pre_false_deriv {c=cf}) (\_, (v, _) => v))
h_pre_false_deriv {c = (CIf1 _ c)} =
  H_If1 (h_consequence_pre (h_pre_false_deriv {c=c}) (\_, (v, _) => v))
        (\_, (v, _) => absurd v)
h_pre_false_deriv {c = (CWhile _ c)} =
  h_consequence_post
    (H_While (h_consequence_pre (h_pre_false_deriv {c=c} {q=const Void})
                                (\_, (v, _) => v)))
    (\_, (v, _) => absurd v)
h_pre_false_deriv {c = f@(CFor init _ updt body)} =
  h_consequence_post
    (H_For (h_pre_false_deriv {c=init} {q=const Void})
           (h_consequence_pre
              (h_pre_false_deriv {c=assert_smaller f (do body; updt)})
              (\_, (v, _) => v)))
    (\_, (v, _) => absurd v)
h_pre_false_deriv {c = (CRepeat c _)} =
  h_consequence_post
    (H_Repeat (h_pre_false_deriv {c=c} {q=const Void}) (\_, (v, _) => v))
    (\_, (v, _) => absurd v)

WP : Com -> Assertion -> Assertion
WP c q = \s => (s' : State) -> CEval c s s' -> q s'

wp_is_precondition : HoareTriple (WP c q) c q
wp_is_precondition _ st' rel = \wp => wp st' rel

wp_is_weakest : HoareTriple p' c q -> (st : State) -> p' st -> WP c q st
wp_is_weakest ht st p'_st = \st', rel => ht st st' rel p'_st

hoare_proof_complete : HoareTriple p c q -> HoareProof p c q
hoare_proof_complete {c = CSkip} ht =
  h_consequence_post H_Skip (\st, p_st => ht st st E_Skip p_st)
hoare_proof_complete {c = (CAss x e)} ht =
  h_consequence_pre
    H_Ass (\st, q_st => ht st (t_update x (aeval st e) st) (E_Ass Refl) q_st)
hoare_proof_complete {q} {c = (CSeq c1 c2)} ht =
  H_Seq
    (hoare_proof_complete
      {c=c1} {q=WP c2 q}
      (\st1, _, r1, p_st, st3, r2 => ht st1 st3 (E_Seq r1 r2) p_st))
    (hoare_proof_complete {c=c2} (\_, st', rel, wp => wp st' rel))
hoare_proof_complete {c = (CIf b ct cf)} ht =
  H_If
    (hoare_proof_complete
      (\st, st', rel, (p_st, prf) => ht st st' (E_IfTrue prf rel) p_st))
    (hoare_proof_complete
      (\st, st', rel, (p_st, contra) =>
        ht st st' (E_IfFalse (bassn_eval_false contra) rel) p_st))
hoare_proof_complete {c = (CIf1 b c)} ht =
  H_If1
    (hoare_proof_complete
      (\st, st', rel, (p_st, prf) => ht st st' (E_If1True prf rel) p_st))
    (\st, (p_st, contra) =>
      ht st st (E_If1False (bassn_eval_false contra)) p_st)
hoare_proof_complete {c = (CWhile b c)} {q} ht =
  H_Consequence
    {p'=WP (CWhile b c) q}
    (H_While
      (hoare_proof_complete {c=c} $ \_, _, rel, (wp, prf), st'', rel' =>
        wp st'' (E_WhileLoop prf rel rel')))
    (\st, p_st, st', rel => ht st st' rel p_st)
    (\st, (wp, contra) => wp st (E_WhileEnd (bassn_eval_false contra)))
hoare_proof_complete {c = f@(CFor init cond updt body)} {q} ht =
  H_Consequence
    {p'=WP (CFor init cond updt body) q}
    (H_For
      {q=WP (CWhile cond (do body; updt)) q}
      (hoare_proof_complete $ \_, _, rel, wp, st'', rel' =>
        wp st'' (E_For rel rel'))
      (hoare_proof_complete
        {c=assert_smaller f (do body; updt)}
        (\_, _, rel, (wp, prf), st'', rel' =>
          wp st'' (E_WhileLoop prf rel rel'))))
    (\st, p_st, st', rel => ht st st' rel p_st)
    (\st, (wp, contra) => wp st (E_WhileEnd (bassn_eval_false contra)))
hoare_proof_complete {c = (CRepeat c b)} {q} ht =
  H_Consequence
    {p'=WP (CRepeat c b) q}
    (H_Repeat
      {q=WP (CWhile (not b) c) q}
      (hoare_proof_complete $
        \_, _, rel, wp, st'', rel' => wp st'' (E_Repeat rel rel'))
      (\st, (wp, contra), st', (E_Repeat r1 r2) =>
        let rel = snd (loop_unrolling {b=not b} {c=c} st st')
                      (E_IfTrue (cong {f=not} (fst not_true_iff_false contra))
                                (E_Seq r1 r2))
        in wp st' rel))
    (\st, p_st, st', rel => ht st st' rel p_st)
    (\st, (wp, prf) => wp st (E_WhileEnd (cong {f=not} prf)))


module FLK_bos

import Data.SortedMap
import FLK_ast

mutual
  syntax "[" [ex1] "=>>" [ex2] "]" =
      ex1 >- _ `BigStep` ex2 >- _

  syntax "[" [ex1] "," [env1] "=>>" [ex2] "," [env2] "]" =
      ex1 >- env1 `BigStep` ex2 >- env2

  -- Big Step rules for FLK
  data BigStep : (CF a) -> (CF b) -> Type where
    DoneEv : {d : Exp Done} -> [d, e =>> d, e]

    Prim1Ev : [e =>> (B b)]
           -> [Prim1 Not e, env =>> B (not b), env]

    Prim2NEv : [e1 =>> (N n1)]
            -> [e2 =>> (N n2)]
            -> [(Prim2 o e1 e2), env =>> (N (arithOp o n1 n2)), env]

    Prim2REv : [e1 =>> (N n1)]
            -> [e2 =>> (N n2)]
            -> [(Prim2 o e1 e2), env =>> (B (relop o n1 n2)), env]

    Prim2Gen : {v1 : Exp Done} -> {v2 : Exp Done}
            -> [e1 =>> v1]
            -> [e2 =>> v2]
            -> [(Prim2 o e1 e2), env =>> genOp o v1 v2, env]
    IfTEv : [cond =>> (B True)]
         -> [t =>> v]
         -> [If cond t f, e =>> v, e]

    IfFEv : [cond =>> (B False)]
         -> [f =>> v]
         -> [If cond t f, e =>> v, e]

    IdValEv : {ident : Ident} -> {e : Env} -> {v : Exp Done}
           -> (v ** lookup ident e = Just $ Left v)
           -> [v, e =>> r, e']
           -> [Id ident, e =>> r, e']

    IdRecEv : {ident : Ident} -> {e : Env} -> {v : Exp RecLam}
           -> (v ** lookup ident e = Just $ Right v)
           -> [v, e =>> r, e']
           -> [Id ident, e =>> r, e']

    LamEv : [Abs x body, env =>> Clos env (Abs x body), env]

    RecEv : {env : Env} -> {ident : Ident} -> {body : Exp a}
         -> [body, (insert ident (Right $ Rec ident body) env) =>> v, env']
         -> [Rec ident body, env =>> v, env']

    AppEv : [func =>> (Clos e (Abs ident body))]
         -> [arg =>> argval]
         -> [body, (insert ident (Left $ argval) e) =>> v,e']
         -> [App func arg, e'' =>> v,e']

  instance Show (BigStep a b) where
    show DoneEv = "DoneEv"
    show (Prim1Ev z) = (show z) ++ " -> PrimEv"
    show (Prim2NEv w u) = (show w) ++ " and " ++ (show u) ++ " -> " ++ "Prim2NEv"
    show (Prim2REv w u) = (show w) ++ " and " ++ (show u) ++ " -> " ++ "Prim2REv"
    show (Prim2Gen w u) = (show w) ++ " and " ++ (show u) ++ " -> " ++ "Prim2GEv"
    show (IfTEv w x1) = (show w) ++ " and " ++ (show x1) ++ " -> " ++ "IfTEv"
    show (IfFEv w x1) = (show w) ++ " and " ++ (show x1) ++ " -> " ++ "IfFEv"
    show (IdValEv x y) = (show y) ++ " -> IdValEv"
    show (IdRecEv x y) = (show y) ++ " -> IdRecEv"
    show LamEv = "LamEv"
    show (RecEv x) = (show x) ++ "-> RecEv"
    show (AppEv s x1 y1) = (show s) ++ " and " ++ (show x1) ++ " and " ++ (show y1) ++ " -> " ++ "AppEv"

  transStr : (CF a) -> (CF b) -> String
  transStr c d = "["++(show c)++"] =>> ["++(show d)++"]"

prim2Lemma : (ot : OpTy) -> (op : Op2 ot) -> (e1 : Exp Done) -> (e2 : Exp Done)
          -> (tr1 : [e1' =>> e1]) -> (tr2 : [e2' =>> e2])
          -> (env : Env)
          -> Maybe (Sigma (CF Done) (\res => Prim2 op e1' e2' >- env `BigStep` res))
prim2Lemma Arith op (N k) (N j) tr1 tr2 y =
  Just ((N $ arithOp op k j) >- y ** Prim2NEv tr1 tr2)
prim2Lemma Arith op e1 e2 tr1 tr2 y = Nothing
prim2Lemma Rel op (N k) (N j) tr1 tr2 y =
  Just ((B $ relop op k j) >- y ** Prim2REv tr1 tr2)
prim2Lemma Rel op e1 e2 tr1 tr2 y = Nothing
prim2Lemma Gen op e1 e2 tr1 tr2 y = Just ((genOp op e1 e2) >- y ** Prim2Gen tr1 tr2)
prim2Lemma Bool op e1 e2 tr1 tr2 y = Nothing

mutual
  syntax "[[" [exp] "," [env] "]]" = evalCF (getTag exp) (exp >- env);

  evalCFI : (st : CF Inter) -> Maybe (Sigma (CF Done) (\st' => st `BigStep` st'))
  evalCFI ((App x z) >- y) = do
    ((stateF >- yF) ** transF) <- [[x, y]]
    ((stateA >- yA) ** transA) <- [[z, y]]
    case stateF of
         (Clos env (Abs ident body)) => do
           ((stateRes >- yRes) ** transRes) <- [[body, (insert ident (Left $ stateA) env)]]
           pure $ ((stateRes >- yRes) ** AppEv transF transA transRes)
         otherwise => Nothing

  evalCFI ((If x z w) >- y) = do
    ((stateC >- _) ** transC) <- [[x, y]]
    case stateC of
         (B False) => do
           ((stateF >- _) ** transF) <- [[w, y]]
           pure (stateF >- y ** (IfFEv transC transF))
         (B True)  => do
           ((stateT >- _) ** transT) <- [[z, y]]
           pure (stateT >- y ** (IfTEv transC transT))
         otherwise => Nothing

  evalCFI ((Prim1 Not z) >- y) = do
    ((state >- _) ** trans') <- [[z, y]]
    case state of
         (B b) => pure ((B $ not b) >- y ** (Prim1Ev trans'))
         otherwise => Nothing

  evalCFI ((Prim2 z w s) >- y) = do
    ((st1 >- _) ** tr1) <- [[w, y]]
    ((st2 >- _) ** tr2) <- [[s, y]]
    prim2Lemma (getOpT z) z st1 st2 tr1 tr2 y

  evalCFI ((Id x) >- y) with (idSteps x y)
    evalCFI ((Id x) >- y) | (Just (MkSigma z pf)) = do {
        ((st >- y') ** trans) <- [[z, y]];
        pure $ ((st >- y') ** (IdValEv (MkSigma z pf) trans))
      }
    evalCFI ((Id x) >- y) | Nothing with (idRecSteps x y)
      evalCFI ((Id x) >- y) | Nothing | Nothing = Nothing
      evalCFI ((Id x) >- y) | Nothing | (Just (MkSigma z pf)) = do {
        ((st >- y') ** trans) <- [[z, y]];
        pure $ ((st >- y') ** (IdRecEv (MkSigma z pf) trans))
      }

  evalCFD : (st : CF Done) -> (Sigma (CF Done) (\st' => st `BigStep` st'))
  evalCFD (x >- z) = (x >- z ** DoneEv)

  evalCFL : (st : CF Lam) -> (Sigma (CF Done) (\st' => st `BigStep` st'))
  evalCFL ((Abs x z) >- y) = ((Clos y (Abs x z)) >- y ** LamEv)

  evalCFR : (st : CF RecLam) -> Maybe (Sigma (CF Done) (\st' => st `BigStep` st'))
  evalCFR ((Rec x z) >- y) = do
    ((stateN >- y') ** transN) <- [[z, (insert x (Right $ Rec x z) y)]]
    pure (stateN >- y' ** RecEv transN)

  evalCF : (s : Status) -> (st : CF s) -> Maybe (Sigma (CF Done) (\st' => st `BigStep` st'))
  evalCF Inter st = evalCFI st
  evalCF Done st = Just $ evalCFD st
  evalCF Lam st = Just $ evalCFL st
  evalCF RecLam st = evalCFR st

evalErase : (Exp s) -> Maybe (CF Done)
evalErase x = [[x, emptyEnv]] >>= (\ (cf ** _) => pure cf)


data Format = Number Format
            | Str Format
            | Character Format
            | Decimal Format
            | Lit String Format
            | End

PrintfType : Format -> Type
PrintfType (Number fmt) = (i:Int) -> PrintfType fmt
PrintfType (Str fmt) = (s:String) -> PrintfType fmt
PrintfType (Character fmt) = (c:Char) -> PrintfType fmt
PrintfType (Decimal fmt) = (d:Double) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType End = String

printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \s => printfFmt fmt (acc ++ s)
printfFmt (Character fmt) acc = \c => printfFmt fmt (acc ++ show c)
printfFmt (Decimal fmt) acc = \d => printfFmt fmt (acc ++ show d)
printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)
printfFmt End acc = acc

toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: 'c' :: chars) = Character (toFormat chars)
toFormat ('%' :: 'f' :: chars) = Decimal (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
                             Lit lit chars' => Lit (strCons c lit) chars'
                             fmt => Lit (strCons c "") fmt

printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""


public export
data Phase = Gas | Liquid | Solid

public export
data ChangePhase : Phase -> Phase -> Type where
	Sequence : ChangePhase a b -> ChangePhase b c -> ChangePhase a c
	Condense : ChangePhase Gas Liquid
	Freeze : ChangePhase Liquid Solid
	Melt : ChangePhase Solid Liquid
	Vaporize : ChangePhase Liquid Gas
	Sublimate : ChangePhase Solid Gas

public export
inferred : { auto transition : ChangePhase l r } -> ChangePhase l r
inferred { transition } = transition

test : ChangePhase Gas Solid
test = inferred


module Quantities.NonSIUnits

import Quantities.FreeAbelianGroup
import Quantities.Core
import Quantities.SIBaseQuantities
import Quantities.SIDerivedQuantities
import Quantities.SIPrefixes
import Quantities.SIBaseUnits
import Quantities.SIDerivedUnits

%default total
%access public export

-- Based on http://en.wikipedia.org/wiki/Non-SI_units_mentioned_in_the_SI

Minute : ElemUnit Time
Minute = < one "min" equals 60 Second >
Min : ElemUnit Time
Min = Minute

Hour : ElemUnit Time
Hour = < one "h" equals 60 Minute >
H : ElemUnit Time
H = Hour

Day : ElemUnit Time
Day = < one "d" equals 24 Hour >
D : ElemUnit Time
D = Day

Week : ElemUnit Time
Week = < one "week" equals 7 Day >

-- Julian year
Year : ElemUnit Time
Year = < one "a" equals 365.25 Day >
JulianYear : ElemUnit Time
JulianYear = Year
A : ElemUnit Time
A = Year

Century : Unit Time
Century = hecto Year

Millenium : Unit Time
Millenium = kilo Year

Tonne : ElemUnit Mass
Tonne = < one "t" equals 1000 Kg >
T : ElemUnit Mass
T = Tonne

Degree : ElemUnit PlaneAngle
Degree = < one "deg" equals (pi / 180) Rad >
Deg : ElemUnit PlaneAngle
Deg = Degree

Arcmin : ElemUnit PlaneAngle
Arcmin = < one "arcmin" equals (1/60) Degree >

Arcsec : ElemUnit PlaneAngle
Arcsec = < one "arcsec" equals (1/60) Arcmin >

-- Ångström (Å)
Angstrom : ElemUnit Length
Angstrom = < one "angstrom" equals 0.1 (nano Metre) >

AstronomicalUnit : ElemUnit Length
AstronomicalUnit = < one "au" equals 149597870700 Metre >
Au : ElemUnit Length
Au = AstronomicalUnit

StandardGravity : ElemUnit Acceleration
--StandardGravity = < one "g_0" equals 9.80665 (Metre <//> (Second ^^ 2)) >
StandardGravity = defineAsMultipleOf "g_0" 9.80665 (Metre <//> (Second ^^ 2))
G_0 : ElemUnit Acceleration
G_0 = StandardGravity

RotationsPerMinute : Unit Frequency
RotationsPerMinute = One <//> Minute
Rpm : Unit Frequency
Rpm = RotationsPerMinute

-- Use this only for relative temparature! Not suitable for conversions of
-- absolute temperature!

Fahrenheit : ElemUnit Temperature
Fahrenheit = < one "dF" equals (5/9) K > -- °F
DF : ElemUnit Temperature
DF = Fahrenheit

Are : ElemUnit Area
Are = < one "are" equals 100 (Metre ^^ 2) >

Hectare : ElemUnit Area
Hectare = < one "ha" equals 1 ((hecto Metre) ^^ 2) >
Ha : ElemUnit Area
Ha = Hectare

Barn : ElemUnit Area
Barn = < one "b" equals 100 ((femto Metre) ^^ 2) >
B : ElemUnit Area
B = Barn

Litre : ElemUnit Volume
Litre = < one "l" equals 1 (milli (Metre ^^ 3)) >
Liter : ElemUnit Volume
Liter = Litre
L : ElemUnit Volume
L = Litre

Bar : ElemUnit Pressure
Bar = < one "bar" equals 100 (kilo Pascal) >

MillimetreOfMercury : ElemUnit Pressure
MillimetreOfMercury = < one "mmHg" equals 133.322 Pascal >
MmHg : ElemUnit Pressure
MmHg = MillimetreOfMercury

Calorie : ElemUnit Energy
Calorie = < one "cal" equals 4.18400 Joule >
ThermochemicalCalorie : ElemUnit Energy
ThermochemicalCalorie = Calorie
Cal : ElemUnit Energy
Cal = Calorie

-- Non-SI units whose values in SI must be determined experimentally

Electronvolt : ElemUnit Energy
Electronvolt = < one "eV" equals 1.60217653 (Ten ^^ -19 <**> Joule) >
EV : ElemUnit Energy
EV = Electronvolt

Dalton : ElemUnit Mass
Dalton = < one "Da" equals 1.66053886 (Ten ^^ -27 <**> Kilogram) >
Da : ElemUnit Mass
Da = Dalton
UnifiedAtomicMassUnit : ElemUnit Mass
UnifiedAtomicMassUnit = Dalton
U : ElemUnit Mass
U = Dalton

-- Atomic and natural units

ElementaryCharge : ElemUnit ElectricCharge
ElementaryCharge = < one "e" equals 1.60217653 (Ten ^^ -19 <**> Coulomb) >
E : ElemUnit ElectricCharge
E = ElementaryCharge

MassOfElectron : ElemUnit Mass
MassOfElectron = < one "m_e" equals 9.1093826 (Ten ^^ -31 <**> Kilogram) >
ElectronMass : ElemUnit Mass
ElectronMass = MassOfElectron
M_e : ElemUnit Mass
M_e = MassOfElectron

BohrRadius : ElemUnit Length
BohrRadius = < one "a_0" equals 0.5291772108 (Ten ^^ -10 <**> Metre) >
Bohr : ElemUnit Length
Bohr = BohrRadius
A_0 : ElemUnit Length
A_0 = BohrRadius

HartreeEnergy : ElemUnit Energy
HartreeEnergy = < one "E_h" equals 4.35974417 (Ten ^^ -18 <**> Joule) >
Hartree : ElemUnit Energy
Hartree = HartreeEnergy
E_h : ElemUnit Energy
E_h = HartreeEnergy

PlanckConstant : ElemUnit (Energy <*> Time)
PlanckConstant = < one "h" equals 6.62606957 (Joule <**> Second) >
H_ : ElemUnit (Energy <*> Time)
H_ = PlanckConstant

ReducedPlanckConstant : ElemUnit (Energy <*> Time)
ReducedPlanckConstant = < one "hBar" equals (1 / (2*pi)) (Joule <**> Second) >
HBar : ElemUnit (Energy <*> Time)
HBar = ReducedPlanckConstant

AtomicUnitOfTime : ElemUnit Time
AtomicUnitOfTime = < one "auOfTime" equals 1 (HBar <//> Hartree) >
AuOfTime : ElemUnit Time
AuOfTime = AtomicUnitOfTime

SpeedOfLight : ElemUnit Speed
SpeedOfLight = < one "c_0" equals 299792458 (Metre <//> Second) >
C_0 : ElemUnit Speed
C_0 = SpeedOfLight

NaturalUnitOfTime : ElemUnit Time
NaturalUnitOfTime = < one "nuOfTime" equals 1 (HBar <//> (M_e <**> (C_0 ^^ 2))) >
NuOfTime : ElemUnit Time
NuOfTime = NaturalUnitOfTime

LightSecond : ElemUnit Length
LightSecond = < one "ls" equals 1 (Second <**> SpeedOfLight) >
Ls : ElemUnit Length
Ls = LightSecond

LightMinute : ElemUnit Length
LightMinute = < one "lmin" equals 1 (Minute <**> SpeedOfLight) >
Lmin : ElemUnit Length
Lmin = LightMinute

LightHour : ElemUnit Length
LightHour = < one "lh" equals 1 (Hour <**> SpeedOfLight) >
Lh : ElemUnit Length
Lh = LightHour

LightDay : ElemUnit Length
LightDay = < one "ld" equals 1 (Day <**> SpeedOfLight) >
Ld : ElemUnit Length
Ld = LightDay

LightWeek : ElemUnit Length
LightWeek = < one "ld" equals 1 (Week <**> SpeedOfLight) >
Lw : ElemUnit Length
Lw = LightWeek

LightYear : ElemUnit Length
LightYear = < one "ly" equals 1 (Year <**> SpeedOfLight) >
Ly : ElemUnit Length
Ly = LightYear

-- Non-SI units associated with the CGS and the CGS-Gaussian system of units

Erg : Unit Energy
Erg = Ten ^^ -7 <**> Joule

Dyne : Unit Force'
Dyne = Ten ^^ -5 <**> Newton
Dyn : Unit Force'
Dyn = Dyne

Poise : Unit DynamicViscosity
Poise = Dyne <**> Second <//> (Centimetre ^^ 2)
P : Unit DynamicViscosity
P = Poise

Stokes : Unit KinematicViscosity
Stokes = Centimetre ^^ 2 <//> Second
St : Unit KinematicViscosity
St = Stokes

Stilb : Unit Luminance
Stilb = Candela <//> (Centimetre ^^ 2)
Sb : Unit Luminance
Sb = Stilb

Phot : Unit Illuminance
Phot = Candela <**> Steradian <//> (Centimetre ^^ 2)
Ph : Unit Illuminance
Ph = Phot

Gal : Unit Acceleration
Gal = Centimetre <//> (Second ^^ 2)

Maxwell : Unit MagneticFlux
Maxwell = Ten ^^ -8 <**> Weber
Mx : Unit MagneticFlux
Mx = Maxwell

Gauss : Unit MagneticFluxDensity
Gauss = Maxwell <//> (Centimetre ^^ 2)
G : Unit MagneticFluxDensity
G = Gauss

Oersted : ElemUnit MagneticFieldStrength
Oersted = < one "oe" equals (250 / pi) (Ampere <//> Metre) >
Oe : ElemUnit MagneticFieldStrength
Oe = Oersted


module TypedContainers.RBTree.Index

import Data.Nat
import Data.DPair
import Data.List
import TypedContainers.In
import TypedContainers.LawfulOrd
import TypedContainers.RBTree.Base

%default total

public export
data Erased : Type -> Type where
  MkErased : (0 _ : a) -> Erased a

0 helper : LawfulOrd a => (x : a) -> (y : a) -> (z : a) -> (x > y = True) -> (y == z = True) -> (x > z = True)
helper x y z p1 p2 =
  let p1' = convGT x y p1 in
  let p2' = convEQ y z p2 in
  let p3 = equality2 y z x p2' in
  let p4 : (compare x z = GT) = replace {p = \arg => arg = GT} p3 p1' in
  cong (\case {GT => True; _ => False}) p4

public export
indexG : {0 keys : List kt} -> {kord : LawfulOrd kt} -> (k : kt) -> {0 k_in_keys : In (k ==) keys} -> GoodTree {kt, kord, keys, vt} -> Exists $ \k' => Exists $ \_ : compare k' k = EQ => vt k'
indexG k (Empty Refl) impossible
indexG k (RedNode k' v l r) = case the (Subset Ordering (compare k' k ===)) $ Element (compare k' k) Refl of
  Element EQ p0 => Evidence k' $ Evidence p0 v
  Element GT p0 =>
    let 0 p1 = \x, p => helper k' k x (cong (\case {GT => True; _ => False}) p0) p in
    let 0 p2 : In (k ==) (filter (k' >) keys) = inFilter (k' >) (k ==) p1 keys k_in_keys in
    indexG k l {k_in_keys = p2}
  Element LT p0 =>
    let 0 p1 = \x, p => ( let p1' = replace {p = \arg => arg = LT} (equality2 k x k' (convEQ k x p)) p0 in let p1'' = cong (\case {LT => True; _ => False}) p1' in the (k' < x = True) p1'' ) in
    let 0 p2 : In (k ==) (filter (k' <) keys) = inFilter (k' <) (k ==) p1 keys k_in_keys in
    indexG k r {k_in_keys = p2}
indexG k (BlackNode k' v l r) = case the (Subset Ordering (compare k' k ===)) $ Element (compare k' k) Refl of
  Element EQ p0 => Evidence k' $ Evidence p0 v
  Element GT p0 =>
    let 0 p1 = \x, p => helper k' k x (cong (\case {GT => True; _ => False}) p0) p in
    let 0 p2 : In (k ==) (filter (k' >) keys) = inFilter (k' >) (k ==) p1 keys k_in_keys in
    indexG k l {k_in_keys = p2}
  Element LT p0 =>
    let 0 p1 = \x, p => ( let p1' = replace {p = \arg => arg = LT} (equality2 k x k' (convEQ k x p)) p0 in let p1'' = cong (\case {LT => True; _ => False}) p1' in the (k' < x = True) p1'' ) in
    let 0 p2 : In (k ==) (filter (k' <) keys) = inFilter (k' <) (k ==) p1 keys k_in_keys in
    indexG k r {k_in_keys = p2}

public export
indexGMaybe : {0 b : kt -> Type} -> {0 keys : List kt} -> {kord : LawfulOrd kt} -> (k : kt)
  -> {0 foldLeft : (Not $ In (k ==) keys) -> a}
  -> {0 foldRight : (k' : kt) -> (compare k' k = EQ, In (k' ==) keys) -> b k'}
  -> GoodTree {kt, kord, keys, vt}
  -> Either (Erased $ a) (DPair kt $ \k' => Exists $ \_ : b k' => vt k')
indexGMaybe k (Empty Refl) = Left $ MkErased $ foldLeft $ \p => case p of
  MkIn _ _ _ impossible
  MkInCons _ _ _ impossible
indexGMaybe k (RedNode k' v l r {kp}) = case the (Subset Ordering (compare k' k ===)) $ Element (compare k' k) Refl of
  Element EQ p0 => Right $ MkDPair k' $ Evidence (foldRight k' (p0, kp)) v
  Element GT p0 =>
    let
      0 p1 : (x : kt) -> (k == x = True) -> (k' > x = True)
      p1 x pp0 = cong (\case { GT => True; _ => False }) $ sym $ trans (sym p0) (equality2 k x k' (convEQ k x pp0))

      0 foldLeft' : (In (k ==) (filter (k' >) keys) -> Void) -> a
      foldLeft' pp0 = foldLeft $ \pp1 => pp0 $ inFilter (k' >) (k ==) p1 keys pp1

      0 foldRight' : (k'' : kt) -> (compare k'' k = EQ, In (k'' ==) (filter (k' >) keys)) -> b k''
      foldRight' k'' (pp0, pp1) = foldRight k'' (pp0, outFilter pp1)
    in
    indexGMaybe k {foldLeft = foldLeft', foldRight = foldRight'} l
  Element LT p0 =>
    let
      0 p1 : (x : kt) -> (k == x = True) -> (k' < x = True)
      p1 x pp0 = cong (\case { LT => True; _ => False }) $ sym $ trans (sym p0) (equality2 k x k' (convEQ k x pp0))

      0 foldLeft' : (In (k ==) (filter (k' <) keys) -> Void) -> a
      foldLeft' pp0 = foldLeft $ \pp1 => pp0 $ inFilter (k' <) (k ==) p1 keys pp1

      0 foldRight' : (k'' : kt) -> (compare k'' k = EQ, In (k'' ==) (filter (k' <) keys)) -> b k''
      foldRight' k'' (pp0, pp1) = foldRight k'' (pp0, outFilter pp1)
    in
    indexGMaybe k {foldLeft = foldLeft', foldRight = foldRight'} r
indexGMaybe k (BlackNode k' v l r {kp}) = case the (Subset Ordering (compare k' k ===)) $ Element (compare k' k) Refl of
  Element EQ p0 => Right $ MkDPair k' $ Evidence (foldRight k' (p0, kp)) v
  Element GT p0 =>
    let
      0 p1 : (x : kt) -> (k == x = True) -> (k' > x = True)
      p1 x pp0 = cong (\case { GT => True; _ => False }) $ sym $ trans (sym p0) (equality2 k x k' (convEQ k x pp0))

      0 foldLeft' : (In (k ==) (filter (k' >) keys) -> Void) -> a
      foldLeft' pp0 = foldLeft $ \pp1 => pp0 $ inFilter (k' >) (k ==) p1 keys pp1

      0 foldRight' : (k'' : kt) -> (compare k'' k = EQ, In (k'' ==) (filter (k' >) keys)) -> b k''
      foldRight' k'' (pp0, pp1) = foldRight k'' (pp0, outFilter pp1)
    in
    indexGMaybe k {foldLeft = foldLeft', foldRight = foldRight'} l
  Element LT p0 =>
    let
      0 p1 : (x : kt) -> (k == x = True) -> (k' < x = True)
      p1 x pp0 = cong (\case { LT => True; _ => False }) $ sym $ trans (sym p0) (equality2 k x k' (convEQ k x pp0))

      0 foldLeft' : (In (k ==) (filter (k' <) keys) -> Void) -> a
      foldLeft' pp0 = foldLeft $ \pp1 => pp0 $ inFilter (k' <) (k ==) p1 keys pp1

      0 foldRight' : (k'' : kt) -> (compare k'' k = EQ, In (k'' ==) (filter (k' <) keys)) -> b k''
      foldRight' k'' (pp0, pp1) = foldRight k'' (pp0, outFilter pp1)
    in
    indexGMaybe k {foldLeft = foldLeft', foldRight = foldRight'} r


import Data.Vect
import Data.Vect.Elem
import Decidable.Equality
import Data.String
import RemoveElem

data WordState : (guesses_remaining : Nat) -> (letters : Nat) -> Type where
     MkWordState : (word : String) ->
                   (missing : Vect letters Char) ->
                   WordState guesses_remaining letters

data Finished : Type where
     Lost : (game : WordState 0 (S letters)) -> Finished
     Won  : (game : WordState (S guesses) 0) -> Finished

data ValidInput : List Char -> Type where
     Letter : (c : Char) -> ValidInput [c]

-- proofs
isValidInput : (cs : List Char) -> Dec (ValidInput cs)
isValidInput [] = No isValidNil where
                     isValidNil : ValidInput [] -> Void
                     isValidNil (Letter c) impossible
isValidInput (x :: []) = Yes (Letter x)
isValidInput (x :: (y :: xs)) = No isValidTooLong where
                                   isValidTooLong : ValidInput (x :: y :: xs) -> Void
                                   isValidTooLong (Letter _ ) impossible

isValidString : (s : String) -> Dec (ValidInput (unpack s))
isValidString s = isValidInput (unpack s)

-- game logic
readGuess : IO (x ** ValidInput x)
readGuess = do putStr "Guess: "
               x <- getLine
               case isValidString (toUpper x) of
                    Yes prf => pure (_ ** prf)
                    No contra => do putStrLn "Invalid guess"
                                    readGuess

processGuess : {letters : _} ->
               (letter : Char) ->
               WordState (S guesses) (S letters) ->
               Either (WordState guesses (S letters))
                      (WordState (S guesses) letters)
processGuess letter (MkWordState word missing) = case isElem letter missing of
                                                      Yes prf => Right (MkWordState word (removeElem letter missing))
                                                      No contra => Left (MkWordState word missing)

game : {guesses : _} -> {letters : _} -> WordState (S guesses) (S letters) -> IO Finished
game st = do (_ ** Letter letter) <- readGuess
             case processGuess letter st of
                  Left l => do putStrLn "Wrong!"
                               case guesses of
                                    0 => pure (Lost l)
                                    (S k) => game l
                  Right r => do putStrLn "Right!"
                                case letters of
                                     0 => pure (Won r)
                                     (S k) => game r

main : IO ()
main = do result <- game {guesses = 2} (MkWordState "Test" ['T', 'E', 'S'])
          case result of
               Lost (MkWordState word missing) => putStrLn ("You lost. The word was " ++ word)
               Won  (MkWordState word missing) => putStrLn ("You won! The word was " ++ word)


module ContT

import Control.Monad.Identity
import Control.Monad.Trans

%access public export

data ContT : (r : Type) -> (m : Type -> Type) -> (a : Type) -> Type where
  ContK : ((a -> m r) -> m r) -> ContT r m a

Cont : Type -> Type -> Type
Cont r a = ContT r Identity a

Functor (ContT r m) where
  map f (ContK c) = ContK (\k => c (\a => k (f a)))

Applicative (ContT r m) where
  pure a = ContK (\k => k a)
  (ContK cf) <*> (ContK c) = ContK (\k => c (\a => cf (\f => k (f a))))

Monad (ContT r m) where
  (ContK c) >>= f = ContK (\k => c (\a => let (ContK k') = f a in k' k))

MonadTrans (ContT r) where
  lift x = ContK (\k => x >>= k)

run : (a -> m r) -> ContT r m a -> m r
run f (ContK c) = c f

reset : Monad m => ContT r m r -> m r
reset (ContK c) = c (\x => pure x)

shift : Monad m => ((a -> m r) -> ContT r m r) -> ContT r m a
shift f = ContK (\k => reset (f k))

callCC : ((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC f = ContK (\k => let (ContK c) = f (\a => ContK (\k' => k a)) in c k)


module Main

data State : (stateType : Type) -> Type -> Type where
  Get : State stateType stateType
  Put : stateType -> State stateType ()

  Pure : ty -> State stateType ty
  Bind : State stateType a -> (a -> State stateType b) -> State stateType b

(>>=) : State stateType a -> (a -> State stateType b) -> State stateType b
(>>=) = Bind

runState : State stateType a -> (st : stateType) -> (a, stateType)
runState Get              st = (st, st)
runState (Put newState)   st = ((), newState)
runState (Pure x)         st = (x, st)
runState (Bind cmd prog)  st =
  let (val, nextState) = runState cmd st
  in runState (prog val) nextState

Functor (State stateType) where
  map func x = Bind x (\val => Pure (func val))

Applicative (State stateType) where
  pure      = Pure
  (<*>) f a =
    Bind f (\f' =>
    Bind a (\a' =>
    Pure (f' a')))

Monad (State stateType) where
  (>>=) = Bind

data Tree a = Empty
            | Node (Tree a) a (Tree a)

Show a => Show (Tree a) where
  show Empty = "Empty"
  show (Node left val right) = "(Node " ++ show left ++ " " ++ show val ++ " " ++ show right ++ ")"

testTree : Tree String
testTree = Node (Node (Node Empty "Jim" Empty)
                      "Fred"
                      (Node Empty "Sheila" Empty))
                "Alice"
                (Node Empty "Bob" (Node Empty "Eve" Empty))

treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))
treeLabelWith Empty = Pure Empty
treeLabelWith (Node left val right) = do
  leftLabelled <- treeLabelWith left
  (this :: rest) <- Get
  Put rest
  rightLabelled <- treeLabelWith right
  Pure (Node leftLabelled (this, val) rightLabelled)

treeLabel : Tree a -> Tree (Integer, a)
treeLabel tree = fst (runState (treeLabelWith tree) [1..])

main : IO ()
main = do
  printLn $ treeLabel testTree


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)

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

display : SchemaType schema -> String
display {schema = SString} item = show item
display {schema = SInt} item = show item
display {schema = SChar} item = show item
display {schema = (y .+. z)} (itemL, itemR) = display itemL ++ ", " ++ display itemR

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)

data Command : Schema -> Type where
    SetSchema : (newSchema : Schema) -> Command schema
    Add : SchemaType schema -> Command schema
    Get : Maybe Integer -> Command schema
    Quit : Command schema

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 = getChar (unpack input)
    where
        getChar : List Char -> Maybe (Char, String)
        getChar (char :: ' ' :: rest) = Just (char, pack rest)
        getChar (char :: []) = Just (char, "")
        getChar _ = Nothing

parsePrefix (schemaL .+. schemaR) input =
    do
        (lVal, input') <- parsePrefix schemaL input
        (rVal, input'') <- parsePrefix schemaR input'
        Just ((lVal, rVal), input'')

parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)
parseBySchema schema input = case parsePrefix schema input of
                                Just (res, "") => Just res
                                Just _ => Nothing
                                Nothing => Nothing

parseSchema : List String -> Maybe Schema
parseSchema ("String" :: xs) =
    case xs of
        [] => Just SString
        _ =>
            do
                restSchema <- parseSchema xs
                Just (SString .+. restSchema)
parseSchema ("Int" :: xs) =
    case xs of
        [] => Just SInt
        _ =>
            do
                restSchema <- parseSchema xs
                Just (SInt .+. restSchema)
parseSchema ("Char" :: xs) =
    case xs of
        [] => Just SChar
        _ =>
            do
                restSchema <- parseSchema xs
                Just (SChar .+. restSchema)
parseSchema _ = Nothing

parseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema)
parseCommand schema "add" rest =
    do
        restOk <- parseBySchema schema rest
        Just (Add restOk)
parseCommand schema "get" "" = Just (Get Nothing)
parseCommand schema "get" val =
    case all isDigit (unpack val) of
        False => Nothing
        True => Just (Get $ Just (cast val))
parseCommand schema "schema" val =
    do
        schemaok <- parseSchema (words val)
        Just (SetSchema schemaok)
parseCommand schema "quit" "" = Just Quit
parseCommand _ _ _ = Nothing

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

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

showItems : Vect len (SchemaType schema) -> String
showItems [] = ""
showItems (item :: items') = display item ++ "\n" ++ showItems items'

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 Nothing) => Just (showItems $ items store, store)
            Just (Get $ Just pos) => getEntry pos store
            Just (SetSchema schema') =>
                case setSchema store schema' of
                    Nothing => Just ("Can't update schema\n", store)
                    Just store' => Just ("OK\n", store')
            Just Quit => Nothing

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


-- --------------------------------------------------------------- [ BTree.idr ]
-- Module    : BTree.idr
-- Copyright : (c) 2015,2016 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| Implementation of a Binary Tree an AVL Binary Search Tree.
|||
||| The underlying AVL Tree is a Key-Value Tree, this library just
||| wraps this up as a simple Binary tree for values i.e. keys.
module Data.AVL.BTree

import Data.AVL

%access export

-- ------------------------------------------------------------- [ Definitions ]

||| A Binary Search Tree.
|||
||| @ty The type of the elements in the tree.
data BTree : (ty : Type) -> Type
    where
      MkTree : {a : Type } -> AVLTree n a Unit -> BTree a

-- --------------------------------------------------------------------- [ API ]

||| Return an empty BTree.
empty : Ord a => BTree a
empty = MkTree (Element Empty AVLEmpty)

||| Insert an element into the Tree.
insert : (Ord a) => a -> BTree a -> BTree a
insert a (MkTree t) = MkTree (snd $ AVL.API.insert a () t)

||| Does the tree contain the given element?
contains : (Ord a) => a -> BTree a -> Bool
contains a (MkTree t) = isJust (AVL.API.lookup a t)

||| How many nodes are in the tree?
size : BTree a -> Nat
size (MkTree t) = AVL.API.size t

||| Construct an ordered list containing the elements of the tree.
toList : BTree a -> List a
toList (MkTree t) = map fst $ AVL.API.toList t

||| Construct a tree from a list of elements.
fromList : (Ord a) => List a -> BTree a
fromList xs = (foldl (\t,k => BTree.insert k t) empty xs)

-- --------------------------------------------------------------- [ Instances ]

Foldable BTree where
  foldr f i (MkTree t) = foldr (\x,_,p => f x p) i t

Eq a => Eq (BTree a) where
  (==) (MkTree (Element t _)) (MkTree (Element t' _)) = t == t'

Show a => Show (BTree a) where
  show s = "{ " ++ (unwords . intersperse "," . map show . BTree.toList $ s) ++ " }"

namespace Quantifier

  data All : (predicate : type -> Type) -> (set : BTree type) -> Type where
    Satisfies : (prf : AllKeys p tree) -> All p (MkTree tree)

namespace Predicate

  data Elem : (value : type) -> (tree : BTree type) -> Type where
    IsElem : (prf : HasKey value tree)
          -> Elem value (MkTree tree)

  private
  elemNotInTree : (prfIsNotElem : HasKey value tree -> Void) -> Elem value (MkTree tree) -> Void
  elemNotInTree prfIsNotElem (IsElem prf) = prfIsNotElem prf

  isElem : DecEq type
        => (value : type)
        -> (tree  : BTree type)
        -> Dec (Elem value tree)
  isElem value (MkTree tree) with (isKey value tree)
    isElem value (MkTree tree) | (Yes prf) = Yes (IsElem prf)
    isElem value (MkTree tree) | (No prfIsNotElem) = No (elemNotInTree prfIsNotElem)

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


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

import Data.Vect

-- check that all functions are total
%default total

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)

addToStore : (store : DataStore) -> SchemaType (schema store) -> 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

||| Supported commands
data Command : Schema -> Type where
               ||| Set schema
               SetSchema : (newSchema : Schema) -> Command schema
               ||| Add an item
               Add : SchemaType schema -> Command schema
               ||| Get an item by its id
               Get : Integer -> Command schema
               ||| List the contents of the store
               List : Command schema
               ||| Get the number of items
               Size : Command schema
               |||| Quit
               Quit : Command schema

parseSchema : List String -> Maybe Schema
parseSchema ("String" :: xs) =
  case xs of
    [] => Just SString
    _ => parseSchema xs >>= Just . (SString .+.)
parseSchema ("Int" :: xs) =
  case xs of
    [] => Just SInt
    _ => parseSchema xs >>= Just . (SInt .+.)
parseSchema ("Char" :: xs) =
  case xs of
    [] => Just SChar
    _ => parseSchema xs >>= Just . (SChar .+.)
parseSchema _ = 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 = case unpack input of
                      [] => Nothing
                      (x :: rest) => Just (x, ltrim (pack rest))
parsePrefix (schema1 .+. schema2) input =
  do (val1, rest1) <- parsePrefix schema1 input
     (val2, rest2) <- parsePrefix schema2 rest1
     Just ((val1, val2), rest2)

parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)
parseBySchema schema input =
  do (res, rest) <- parsePrefix schema input
     if rest == "" then Just res else Nothing

parseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema)
parseCommand schema "schema" rest
  = parseSchema (words rest) >>= Just . SetSchema
parseCommand schema "add" rest
  = parseBySchema schema rest >>= Just . Add
parseCommand schema "get" "" = Just List
parseCommand schema "get" val = case all isDigit (unpack val) of
                                  False => Nothing
                                  True => Just (Get (cast val))
parseCommand schema "size" "" = Just Size
parseCommand schema "quit" "" = Just Quit
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 = item
display {schema = SInt} item = show item
display {schema = SChar} item = show item
display {schema = (x .+. y)} (item1, item2)
  = display item1 ++ ", " ++ display item2

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 store_items) ++ "\n", store)

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

presentResults : Vect _ (Nat, SchemaType schema) -> String
presentResults results = foldl (++) "" $ map helper results
  where
    helper : (Nat, SchemaType schema) -> String
    helper (x, res) = show x ++ ": " ++ (display res) ++ "\n"

listStore : (store : DataStore) -> String
listStore store = presentResults $ helper (items store) 0
  where
    helper : Vect size' (SchemaType (schema store)) ->
             Nat ->
             Vect size' (Nat, SchemaType (schema store))
    helper [] _ = []
    helper (x :: xs) k = (k, x) :: helper xs (S k)

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
  = case parse (schema store) input of
        Nothing => Just ("Invalid command\n", store)
        Just (SetSchema schema') =>
          case setSchema store schema' of
            Nothing => Just ("Can't update schema\n", store)
            Just store' => Just ("OK\n", store')
        Just (Add item) =>
          Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
        Just (Get pos) => getEntry pos store
        Just List => Just (listStore store, store)
        Just Size => Just (show (size store) ++ "\n", store)
        Just Quit => Nothing

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


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

import Control.Arrow
import Control.Category
import Data.Morphisms
import Data.Vect

import Effects
import Effect.Random

%access export

-- --------------------------------------------------------- [ 5.2.4 Exercises ]

||| Attempt to convert a string to a natural number.
|||
||| If `s` contains only digits, return `Just` the natural number it represents,
||| otherwise `Nothing`.
|||
||| ```idris example
||| stringToNat "123"
||| ```
||| ```idris example
||| stringToNat "bad"
||| ```
|||
||| @ string the string to try to convert
stringToNat : (string : String) -> Maybe Nat
stringToNat s = if all isDigit (unpack s)
                   then Just (cast s)
                   else Nothing

handleGuess : Nat -> IO () -> Maybe Nat -> IO ()
handleGuess _ loop Nothing           = putStrLn "Invalid number" *> loop
handleGuess target loop (Just guess) =
    case compare guess target of
         LT => putStrLn "Too low!"  *> loop
         EQ => putStrLn "Correct!"
         GT => putStrLn "Too high!" *> loop

readNumber : IO (Maybe Nat)
readNumber = stringToNat <$> getLine

namespace Simple

    ||| A simple "guess the number" game.
    |||
    ||| Repeatedly ask the user to guess a number and display whether the guess
    ||| is too high, too low, or correct. When the guess is correct, exit.
    |||
    ||| @ target the number to be guessed
    partial
    guess : (target : Nat) -> IO ()
    guess target = putStrLn "===> Guess the number" *> loop
      where
        partial
        loop : IO ()
        loop = putStr "> " *> handleGuess target loop !readNumber

    partial
    main : IO ()
    main = guess $ fromIntegerNat !(run (rndInt 1 100))

namespace Counting

    partial
    guess : (target, guesses : Nat) -> IO ()
    guess target guesses = putStrLn "===> Guess the number" *> loop
      where
        partial
        loop : IO ()
        loop = do putStrLn $ "Guesses so far: " ++ show guesses
                  putStr "> " *> handleGuess target loop !readNumber

    partial
    main : IO ()
    main = guess $ fromIntegerNat !(run (rndInt 1 100))

namespace DIY

    %hide Prelude.Interactive.replWith

    partial
    replWith : a -> String -> (a -> String -> Maybe (String, a)) -> IO ()
    replWith state prompt func =
        do putStr prompt
           case func state !getLine of
                Just (output, newState) => do putStr output
                                              replWith newState prompt func
                Nothing                 => pure ()

    %hide Prelude.Interactive.repl

    partial
    repl : String -> (String -> String) -> IO ()
    repl prompt func = replWith () prompt (flip (curry go))
      where
        go : (String, a) -> Maybe (String, a)
        go = applyMor $ first (arrow func) >>> arrow pure

-- --------------------------------------------------------- [ 5.3.5 Exercises ]

||| Read input from the console until the user enters a blank line.
partial
readToBlank : IO (List String)
readToBlank = case !getLine of
                   "" => pure []
                   x  => pure (x :: !readToBlank)

||| Read input from the console until the user enters a blank line,
||| then read a file name from the console, and write the input to the file.
partial
readAndSave : IO ()
readAndSave = do putStrLn "Input:"
                 contents <- unlines <$> readToBlank
                 putStr "Filename: "
                 Right file <- writeFile !getLine contents
                   | Left err => printLn err
                 putStrLn "done"

namespace ReadVectFile

    ||| Read the contents of a file into a dependent pair containing a length
    ||| and a `Vect` of that length.
    ||| If there are any errors, return the empty vector.
    partial
    readVectFile : (filename : String) -> IO (n ** Vect n String)
    readVectFile filename = do Right xs <- map lines <$> readFile filename
                                 | Left err => (printLn err *> pure (_ ** []))
                               pure (_ ** fromList xs)

    main : IO ()
    main = putStr "Filename: " *> printLn !(readVectFile !getLine)

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


module Sub13Apply108x36

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof

%default total
-- %language ElabReflection

-- 3(36x+12) --F[5,-2]->B[1,-2]--> 3(16x+5)
export
apply108x36 : (Not . P) (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                    (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))
                                              (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))))
  -> (m : Nat **
        (LTE (S m)
             (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                        (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))
                                  (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))),
         (Not . P) m))
apply108x36 {o} col = ((S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))
                                                           ** (lte108x36 o, fb108x36To48x15 o col)) where
  lte108x36 : (o:Nat) -> LTE (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))
                                  (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))))
          (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                     (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))
                               (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))))
  lte108x36 Z = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte108x36 (S o) = let lemma = lte108x36 o in

    rewrite (sym (plusSuccRightSucc o o)) in

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

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

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

    rewrite (sym (plusSuccRightSucc (plus o o)  o)) in

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

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

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

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

      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) lemma


module LeftPad

import Data.Vect
import Data.Vect.Quantifiers

simpleLeftPad : Char -> Int -> String -> Int
simpleLeftPad = 2

testing : String -> Type
testing "Give me text" = String
testing _              = Int

-- `minus` is saturating subtraction, so this works like we want it to
eq_max : (n, k : Nat) -> maximum k n = plus (n `minus` k) k
eq_max  n     Z    = rewrite minusZeroRight n in
                     rewrite plusZeroRightNeutral n in Refl
eq_max  Z    (S _) = Refl
eq_max (S n) (S k) = rewrite sym $ plusSuccRightSucc (n `minus` k) k in rewrite eq_max n k in Refl

-- The type here says "the result is" padded to (maximum k n), and is padding plus the original
leftPad : (x : a) -> (n : Nat) -> (xs : Vect k a)
       -> (ys : Vect (maximum k n) a ** m : Nat ** ys = replicate m x ++ xs)
leftPad {k} x n xs = rewrite eq_max n k in (replicate (n `minus` k) x ++ xs ** n `minus` k ** Refl)

-- helperProof : (m : Fin n) -> Vect n a -> Vect (cast m) a
-- helperProof FZ v = []
-- helperProof (FS x) (y :: xs) = y :: helperProof x xs

-- minusItselfZero : (a : Nat) -> (b : Nat) -> LTE b a -> Vect (a - b + b) Char = Vect a Char
-- minusItselfZero a b p = ?minusItselfZero_rhs1

-- leftPad : (c : Char)
--         -> (s : List Char)
--         -> (n : Nat)
--         -> (case isLTE (length s) (S n) of
--                  No _ => (x : List Char ** (x = s))
--                  Yes _ => (v : Vect (S n) Char
--                               **
--                               (y : Vect ((S n) - (length s)) Char ** (y ++ (fromList s) = v))))
-- leftPad padChar s n with (isLTE (length s) (S n))
--   leftPad padChar s n | No _ = (s ** Refl)
--   leftPad padChar s n | Yes lteproof = let paddingVec = replicate ((S n) - (length s)) padChar
--                                            newVec = paddingVec ++ (fromList s)
--                                        in rewrite sym (minusItselfZero (S n) (length s) lteproof) in (newVec ** (paddingVec ** ?jotain))


import Data.Vect

export
data StackCmd : Type -> Nat -> Nat -> Type where
  Push : Integer -> StackCmd ()      height     (S height)
  Pop :             StackCmd Integer (S height) height
  Top :             StackCmd Integer (S height) (S height)

  GetStr : StackCmd String height height
  PutStr : String -> StackCmd () height height

  Pure : ty -> StackCmd ty height height
  (>>=) : StackCmd a height1 height2 ->
          (a -> StackCmd b height2 height3) ->
          StackCmd b height1 height3

runStack : (stk : Vect inHeight Integer) ->
           StackCmd ty inHeight outHeight ->
           IO (ty, Vect outHeight Integer)
runStack stk (Push val) = pure ((), val :: stk)
runStack (val :: stk) Pop = pure (val, stk)
runStack (val :: stk) Top = pure (val, val :: stk)
runStack stk GetStr = do x <- getLine
                         pure (x, stk)
runStack stk (PutStr x) = do putStr x
                             pure ((), stk)
runStack stk (Pure x) = pure (x, stk)
runStack stk (x >>= f) = do (x', newStk) <- runStack stk x
                            runStack newStk (f x')

testAdd : StackCmd () 0 0
testAdd = do Push 10
             x <- GetStr
             Push (cast x)
             val1 <- Pop
             val2 <- Pop
             PutStr (show (val1 + val2) ++ "\n")

export
data StackIO : Nat -> Type where
  Do : StackCmd a height1 height2 ->
       (a -> Inf (StackIO height2)) -> StackIO height1

namespace StackDo
  export
  (>>=) : StackCmd a height1 height2 ->
          (a -> Inf (StackIO height2)) -> StackIO height1
  (>>=) = Do

data Fuel = Dry | More (Lazy Fuel)

partial
forever : Fuel
forever = More forever

run : Fuel -> Vect height Integer -> StackIO height -> IO ()
run Dry _ _ = pure ()
run (More fuel) stk (Do c f) = do (res, newStk) <- runStack stk c
                                  run fuel newStk (f res)

doAdd : StackCmd () (S (S height)) (S height)
doAdd = do val1 <- Pop
           val2 <- Pop
           Push (val1 + val2)

data StkInput = Number Integer
              | Add

strToInput : String -> Maybe StkInput
strToInput "" = Nothing
strToInput "add" = Just Add
strToInput x = if all isDigit (unpack x)
                  then Just (Number $ cast x)
                  else Nothing

mutual
  tryAdd : {height : _} -> StackIO height
  tryAdd {height = S (S h)} = do doAdd
                                 result <- Top
                                 PutStr (show result ++ "\n")
                                 stackCalc
  tryAdd = do PutStr "Fewer than two items on the stack\n"
              stackCalc

  stackCalc : {height : _} -> StackIO height
  stackCalc = do PutStr "> "
                 input <- GetStr
                 case strToInput input of
                      Nothing => do PutStr "Invalid input\n"
                                    stackCalc
                      Just (Number x) => do Push x
                                            stackCalc
                      Just Add => tryAdd

main : IO ()
main = run forever [] stackCalc


module Scheme.Core

import Control.Isomorphism
import Data.Vect

%default total
%access public export

-- TODO Integer <= Rational <= Real <= Complex
-- TODO Exact | Inexact
||| [S]cheme [Num]ber
data SNum : Type where
  SNExactInt : Integer -> SNum

||| [S]ymbolic [Exp]ression
data SExp : Type where
  ||| Symbols are just identifiers or pointers
  ||| They evaluate to something if defined in current scope
  ||| Some are special forms that are evaluated under different rules
  SESymbol  : String -> SExp
  ||| Unit is an empty list
  SEUnit    : SExp
  ||| Cons is the basic building block and the only way to apply a function
  SECons    : SExp -> SExp -> SExp
  ||| Vector should be just an O(1) access List
  ||| Vectors are terminal
  SEVect    : Vect n SExp -> SExp
  ||| Booleans are terminal
  SEBool    : Bool -> SExp
  ||| Chars are terminal
  SEChar    : Char -> SExp
  ||| Strings are terminal
  SEStr     : String -> SExp
  ||| Numbers are terminal
  SENum     : SNum -> SExp

listify : SExp -> (List SExp, Maybe SExp)
listify SEUnit       = ([], Nothing)
listify (SECons x y) = let (ls, md) = listify y
                        in (x :: ls, md)
listify x            = ([], Just x)

unListify : (List SExp, Maybe SExp) -> SExp
unListify (xs, ms) = foldr SECons (maybe SEUnit id ms) xs

-- unListify : (List SExp, Maybe SExp) -> SExp
-- unListify ([]     , Nothing) = SEUnit
-- unListify ([]     , Just s ) = s
-- unListify (x :: xs, ms     ) = SECons x $ assert_total $ unListify (xs, ms)

-- ||| A theorem about lists and dotted lists
-- lispIso : Iso SExp (List SExp, Maybe SExp)
-- lispIso = MkIso to from toFrom fromTo
--   where
--     to : SExp -> (List SExp, Maybe SExp)
--     to = listify
--     from : (List SExp, Maybe SExp) -> SExp
--     from = unListify
--     toFrom : (p : (List SExp, Maybe SExp)) -> to (from p) = p
--     toFrom ([]     , Nothing) = Refl
--     toFrom ([]     , Just s ) = ?toFrom_rhs_5
--     toFrom (x :: xs, Nothing) = ?toFrom_rhs_4
--     toFrom (x :: xs, Just s ) = ?toFrom_rhs_1
--     fromTo : (s : SExp) -> from (to s) = s
--     fromTo SEUnit       = Refl
--     fromTo (SESymbol x) = Refl
--     fromTo (SEVect xs ) = Refl
--     fromTo (SEBool x  ) = Refl
--     fromTo (SEChar x  ) = Refl
--     fromTo (SEStr x   ) = Refl
--     fromTo (SENum x   ) = Refl
--     fromTo (SECons x y) = ?whasdasd


%default total

data Foo : Type where
  Fee : Foo

x : Foo
x = Fee

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


data Format = Num Format
            | Str Format
            | Lit String Format
            | End

PrintfType : Format -> Type
PrintfType (Num fmt)   = Int    -> PrintfType fmt
PrintfType (Str fmt)   = String -> PrintfType fmt
PrintfType (Lit x fmt) = PrintfType fmt
PrintfType End         = String

parseFormat : List Char -> Format
parseFormat [] = End
parseFormat ('%' :: 'd' :: xs) = Num (parseFormat xs)
parseFormat ('%' :: 's' :: xs) = Str (parseFormat xs)
parseFormat ('%' :: xs) = Lit "%" (parseFormat xs)
parseFormat (x :: xs) = case parseFormat xs of
                           Lit lit xs' => Lit (strCons x lit) xs'
                           fmt => Lit (strCons x "") fmt

printfFmt : (fmt : Format) -> String -> PrintfType fmt
printfFmt (Num y) x = \i => printfFmt y (x ++ show i)
printfFmt (Str y) x = \s => printfFmt y (x ++ s)
printfFmt (Lit y z) x = printfFmt z (x ++ y)
printfFmt End x = x

printf : (s: String) -> PrintfType (parseFormat (unpack s))
printf s = printfFmt (parseFormat (unpack s)) ""