module Eff

-- The Eff monad, based on http://okmij.org/ftp/Haskell/extensible/more.pdf

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

data Eff : List (Type -> Type) -> Type -> Type where
  Pure : a -> Eff xs a
  Bind : {e : Exists xs f} -> f a -> (a -> Eff xs b) -> Eff xs b

(>>=) : Eff xs a -> (a -> Eff xs b) -> Eff xs b
(>>=) (Pure x) f = f x
(>>=) (Bind {e} x g) f = Bind {e} x (\a => (g a) >>= f)

-- State effect
data State : (s : Type) -> Type -> Type where
  Get : State s s
  Put : s -> State s ()

get : {auto e : Exists xs (State s)} -> Eff xs s
get {e} = Bind {e} Get Pure

put : {auto e : Exists xs (State s)} -> s -> Eff xs ()
put {e} s = Bind {e} (Put s) Pure

-- Reader effect
data Reader : (e : Type) -> Type -> Type where
  Ask : Reader e e

ask : {auto e : Exists xs (Reader en)} -> Eff xs en
ask {e} = Bind {e} Ask Pure

-- Interpreters
runState : s -> Eff ((State s) :: xs) a -> Eff xs (a, s)
runState s (Pure x) = Pure (x, s)
runState s (Bind {e = Here} Get f) = runState s (f s)
runState s (Bind {e = Here} (Put s') f) = runState s' (f ())
runState s (Bind {e = (There e')} fa f) = Bind {e = e'} fa (\x => runState s (f x))

runReader : en -> Eff ((Reader en) :: xs) a -> Eff xs a
runReader en (Pure x) = Pure x
runReader en (Bind {e = Here} Ask f) = runReader en (f en)
runReader en (Bind {e = (There e')} fa f) = Bind {e = e'} fa (\x => runReader en (f x))

run : Eff [] a -> a
run (Pure x) = x
run (Bind {e = Here} _ _) impossible
run (Bind {e = (There _)} _ _) impossible

--
example : Eff [State Int, Reader Int] Int
example = do s <- get
             put (s + 1)
             s <- get
             a <- ask
             Pure (s + a)

test : Int
test = (fst . run . runReader 1 . runState 0) example


module FuncImpl

public export
interface Monad m => FooBar m where
  Foo    : {A : Type} -> A -> m A -> Type
  bar    : {A : Type} -> (ma : m A) -> m (DPair A (\ a => Foo a ma))
  foobar : {A : Type} -> (ma : m A) -> map DPair.fst (bar ma) = ma


module Daten

-- Liste
zahlen : List Nat
zahlen = [1,2,3,4,5]

zahlen' : List Nat
zahlen' = [1..5]

namen : List String
namen = "Marie" :: "Carsten" :: []

-- Tuple
person : (String, Nat)
person = ("Max", 40)

-- union Type
data Farbe
  = Rot
  | Blau

data Ergebnis
  = Fehler String
  | Erfolg Int

-- GADT
data Ergebnis' : Type where
  Fehler' : String -> Ergebnis'
  Erfolg' : Int -> Ergebnis'

data Expression : Type -> Type where
  Falsch : Expression Bool
  Wahr : Expression Bool
  Zahl : Nat -> Expression Nat
  Plus : Expression Nat -> Expression Nat -> Expression Nat
  Gleich : Expression Nat -> Expression Nat -> Expression Bool
  Falls : Expression Bool -> Expression a -> Expression a -> Expression a


module FreeDelivery

-- Based on https://www.cs.ox.ac.uk/jeremy.gibbons/publications/delivery.pdf

data FreeA : (Type -> Type) -> Type -> Type where
  Pure : a -> FreeA f a
  More : f (a -> b) -> FreeA f a -> FreeA f b

Functor f => Functor (FreeA f) where
  map f (Pure x) = Pure $ f x
  map f (More fab ffa) = More (map (f .) fab) ffa

Functor f => Applicative (FreeA f) where
 pure x = Pure x

 (Pure f) <*> fa = map f fa
 (More h fa') <*> fa = More (map uncurry h) (pure (\x, y => (x, y)) <*> fa' <*> fa)

data Command : Type -> Type where
  Say : String -> Command ()
  Toast : Int -> Command ()
  Sense : Command Int

interface SerializeCommand a where
  serialize : a -> (String, String)
interface DeserializeCommand a where
    deserialize : a -> (String, String) -> Maybe a

SerializeCommand (Command a) where
  serialize (Say x) = ("Say", x)
  serialize (Toast x) = ("Toast", show x)
  serialize Sense = ("Sense", "")

DeserializeCommand (Command a) where
  deserialize (Say _) ("Say", s) = Just $ Say s
  deserialize (Toast _) ("Toast", s) = Just $ Toast (cast s)
  deserialize Sense ("Sense", s) = Just $ Sense
  deserialize _ _ = Nothing

data ActionA : Type -> Type where
  Con : Command r -> (r -> a) -> ActionA a

Functor ActionA where
  map f (Con c k) = Con c (f . k)

ProgramA : Type -> Type
ProgramA a = FreeA ActionA a

effectA : Command r -> ProgramA r
effectA c = More (Con c (\r, () => r)) (Pure ())

sayA : String -> ProgramA ()
sayA s = effectA (Say s)

toastA : Int -> ProgramA ()
toastA n = effectA (Toast n)

senseA : ProgramA Int
senseA = effectA Sense

straightA : Int -> ProgramA (Int, Int)
straightA n = pure (\t, (), t' => (t, t')) <*> senseA <*> toastA n <*> senseA

serializeA : ProgramA a -> List (String, String)
serializeA (Pure _) = []
serializeA (More (Con c _) fa') = serialize c :: serializeA fa'

deserializeA : ProgramA a -> List (String, String) -> Maybe (ProgramA a)
deserializeA (Pure x) [] = Just $ Pure x
deserializeA (More (Con c k) fa') (s :: ss) with (deserialize c s)
  deserializeA (More (Con c k) fa') (s :: ss) | Nothing = Nothing
  deserializeA (More (Con c k) fa') (s :: ss) | (Just c') = pure (More (Con c' k)) <*> deserializeA fa' ss
deserializeA _ _ = Nothing

testSerialize : List (String, String)
testSerialize = serializeA (straightA 1)

testDeserialize : Maybe (ProgramA (Int, Int))
testDeserialize = deserializeA (straightA 2) testSerialize


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

get : State stateType stateType
get = Get

put : stateType -> State stateType ()
put = Put

pure : ty -> State stateType ty
pure = Pure

(>>=) : 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)  _  = ((), newState)
runState (Pure x)        st = (x, st)
runState (Bind cmd prog) st =
  let
    (val, nextState) = runState cmd st
  in
    runState (prog val) nextState

implementation Functor (State stateType) where
  map func stA = Bind stA (\valA => Pure (func valA))

implementation Applicative (State stateType) where
  pure  x   = Pure x
  (<*>) x y = Bind x (\func => map func y)

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

addIfPositive : Integer -> State Integer Bool
addIfPositive x =
  let
    isPositive = x > 0
  in
    do when isPositive (
        do current <- get
           put (current + x)
       )
       pure isPositive

addPositives : List Integer -> State Integer Nat
addPositives xs = do added <- traverse addIfPositive xs
                     pure (length (filter id added))

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

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

labelTreeWith2 : Tree a -> State (Stream label) (Tree (label, a))
labelTreeWith2 Empty                  = pure Empty
labelTreeWith2 (Node left elem right) =
  do
    lbldLeft <- labelTreeWith2 left
    (this :: rest) <- get
    put rest
    lbldRight <- labelTreeWith2 right
    pure (Node lbldLeft (this, elem) lbldRight)

flatten : Tree a -> List a
flatten Empty = []
flatten (Node left val right) = flatten left ++ (val :: flatten right)

deepFirst : Tree elem -> Tree (Int, elem)
deepFirst tree = fst (runState (labelTreeWith2 tree) [1..])


> module List.Properties

> import Data.List
> import Data.List.Quantifiers
> import Data.Fin
> import Control.Isomorphism
> import Syntax.PreorderReasoning

> import List.Operations
> import Fun.Operations
> import Fun.Properties
> import Unique.Predicates
> import Finite.Predicates
> import Finite.Operations
> import Sigma.Sigma
> import Pairs.Operations
> import Basic.Operations
> -- import Isomorphism.Operations
> import Fin.Properties
> import Void.Properties
> import Unit.Properties
> import Num.Refinements
> import Pair.Properties

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

* |List| is a functor:

> -- functorSpec1 : fmap . id = id

> -- functorSpec2 : fmap (f . g) = (fmap f) . (fmap g)

* |List| is a monad:

> -- monadSpec1 : (fmap f) . ret = ret . f

> -- monadSpec21 : bind (ret a) f = f a

> -- monadSpec22 : bind ma ret = ma

> -- monadSpec23 : {A, B, C : Type} -> {f : A -> M B} -> {g : B -> M C} ->
> --                bind (bind ma f) g = bind ma (\ a => bind (f a) g)

* |List| is a container monad:

> |||
> elemNonEmptySpec0 : {A : Type} ->
>                     (a : A) -> (as : List A) ->
>                     a `Elem` as -> List.Operations.NonEmpty as
> elemNonEmptySpec0 _  Nil      p = absurd p
> elemNonEmptySpec0 _ (a :: as) _ = ()

> |||
> elemNonEmptySpec1 : {A : Type} ->
>                     (as : List A) ->
>                     List.Operations.NonEmpty as -> Sigma A (\ a => a `Elem` as)
> elemNonEmptySpec1  Nil      c = void c
> elemNonEmptySpec1 (a :: as) _ = MkSigma a Here

> |||
> containerMonadSpec1 : {A : Type} -> {a : A} -> a `Elem` (ret a)
> containerMonadSpec1 {A} {a} = Here

> -- containerMonadSpec2 : {A : Type} -> (a : A) -> (ma : M A) -> (mma : M (M A)) ->
> --                       a `Elem` ma -> ma `Elem` mma -> a `Elem` (join mma)

> containerMonadSpec3 : {A : Type} -> {P : A -> Type} -> (a : A) -> (as : List A) ->
>                       All P as -> a `Elem` as -> P a
> containerMonadSpec3 a'  Nil       _           eprf        = absurd eprf
> containerMonadSpec3 a' (a :: as)  Nil         _           impossible
> containerMonadSpec3 a  (a :: as) (pa :: pas)  Here        = pa
> containerMonadSpec3 a' (a :: as) (pa :: pas) (There eprf) = containerMonadSpec3 a' as pas eprf

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

> -- containerMonadSpec5 : {A : Type} -> {P : A -> Type} ->
> --                       (as : List A) -> ((a : A) -> a `Elem` as -> P a) -> All P as

* Specific container monad properties

> |||
> uniqueAllLemma : {A : Type} -> {P : A -> Type} ->
>                  Unique1 P -> (as : List A) -> Unique (All P as)
> uniqueAllLemma u1P  Nil      Nil Nil = Refl
> uniqueAllLemma u1P (a :: as) (pa :: pas) (pa' :: pas') =
>     ( pa :: pas )
>   ={ replace {P = \ ZUZU => pa :: pas = ZUZU :: pas} (u1P a pa pa') Refl }=
>     ( pa' :: pas )
>   ={ replace {P = \ ZUZU => pa' :: pas = pa' :: ZUZU} (uniqueAllLemma u1P as pas pas') Refl }=
>     ( pa' :: pas' )
>   QED

> |||
> finiteAllLemma0 : {A : Type} -> {P : A -> Type} ->
>                   Finite1 P -> Iso (All P Nil) Unit
> finiteAllLemma0 f1P = MkIso to from toFrom fromTo where
>   to : All P Nil -> Unit
>   to Nil = ()
>   from : Unit -> All P Nil
>   from () = Nil
>   toFrom : (k : Unit) -> to (from k) = k
>   toFrom () = Refl
>   fromTo : (nil : All P Nil) -> from (to nil) = nil
>   fromTo Nil = Refl

> |||
> finiteAllLemma1 : {A : Type} -> {P : A -> Type} ->
>                   Finite1 P -> (a : A) -> (as : List A) ->
>                   Iso (All P (a :: as)) (P a, All P as)
> finiteAllLemma1 {P} f1P a as = MkIso to from toFrom fromTo where
>   to : All P (a :: as) -> (P a, All P as)
>   to (pa :: pas) = (pa, pas)
>   from : (P a, All P as) -> All P (a :: as)
>   from (pa, pas) = pa :: pas
>   toFrom : (papas : (P a, All P as)) -> to (from papas) = papas
>   toFrom (pa, pas) = Refl
>   fromTo : (papas : All P (a :: as)) -> from (to papas) = papas
>   fromTo (pa :: pas) = Refl

> |||
> finiteAllLemma : {A : Type} -> {P : A -> Type} ->
>                  Finite1 P -> (as : List A) -> Finite (All P as)
> finiteAllLemma {P} f1P Nil = MkSigma (S Z) iso where
>   iso : Iso (All P Nil) (Fin (S Z))
>   iso = isoTrans (finiteAllLemma0 f1P) (isoSym isoFin1Unit)
> finiteAllLemma {P} f1P (a :: as) = MkSigma n iso where
>   fH : Finite (P a)
>   fH = f1P a
>   mH : Nat
>   mH = getWitness fH
>   isoH : Iso (P a) (Fin mH)
>   isoH = getProof fH
>   fT : Finite (All P as)
>   fT = finiteAllLemma f1P as
>   mT : Nat
>   mT = getWitness fT
>   isoT : Iso (All P as) (Fin mT)
>   isoT = getProof fT
>   n  : Nat
>   n  = mH * mT
>   iso1 : Iso (All P (a :: as)) (P a, All P as)
>   iso1 = finiteAllLemma1 f1P a as
>   iso2 : Iso (P a, All P as) (Fin mH, Fin mT)
>   iso2 = pairCong isoH isoT
>   iso3 : Iso (Fin mH, Fin mT) (Fin (mH * mT))
>   iso3 = finPairTimes
>   iso  : Iso (All P (a :: as)) (Fin n)
>   iso  = isoTrans iso1 (isoTrans iso2 iso3)

> |||
> finiteAll : {A : Type} -> {P : A -> Type} ->
>             Finite1 P -> (as : List A) -> Finite (All P as)
> finiteAll = finiteAllLemma

> ||| All is decidable
> decidableAll : {A : Type} -> {P : A -> Type} ->
>                (dec : (a : A) -> Dec (P a)) -> (as : List A) -> Dec (All P as)
> decidableAll = all

> ||| NotEmpty is finite
> finiteNonEmpty : {A : Type} -> (as : List A) -> Finite (List.Operations.NonEmpty as)
> finiteNonEmpty  Nil      = finiteVoid
> finiteNonEmpty (a :: as) = finiteUnit

> ||| NonEmpty is decidable
> decidableNonEmpty : {A : Type} -> (as : List A) -> Dec (List.Operations.NonEmpty as)
> decidableNonEmpty {A} Nil       = No absurd
> decidableNonEmpty {A} (a :: as) = Yes ()

> ||| tagElem preserves length
> tagElemPreservesLength : {A : Type} -> (as : List A) -> length (tagElem as) = length as
> tagElemPreservesLength  Nil      = Refl
> tagElemPreservesLength (a :: as) = ( length (tagElem (a :: as)) )
>                                  ={ Refl }=
>                                    ( length ((MkSigma a Here) :: (map (idThere a as) (tagElem as))) )
>                                  ={ Refl }=
>                                    ( S (length (map (idThere a as) (tagElem as))) )
>                                  ={ cong (mapPreservesLength (idThere a as) (tagElem as)) }=
>                                    ( S (length (tagElem as)) )
>                                  ={ cong (tagElemPreservesLength as) }=
>                                    ( S (length as) )
>                                  ={ Refl }=
>                                    ( length (a :: as) )
>                                  QED

* |nub| preserves non-emptiness:

> nubPreservesNonEmpty : {A : Type} -> (Eq A) =>
>                        (as : List A) ->
>                        List.Operations.NonEmpty as ->
>                        List.Operations.NonEmpty (nub as)
> nubPreservesNonEmpty Nil ne = absurd ne
> nubPreservesNonEmpty (a :: as) ne = ()

* |fmap| preserves shape:

> mapPreservesNonEmpty : {A, B : Type} ->
>                        (f : A -> B) -> (as : List A) ->
>                        List.Operations.NonEmpty as ->
>                        List.Operations.NonEmpty (map f as)
> mapPreservesNonEmpty f Nil ne = absurd ne
> mapPreservesNonEmpty f (a :: as) ne = ()

* Fusion-related properties:

> |||
> mapSndMapCrossAnyIdLemma : {A, B, C : Type} ->
>                            (f : A -> C) ->
>                            (abs : List (A, B)) ->
>                            map snd (map (cross f id) abs) = map snd abs
> mapSndMapCrossAnyIdLemma _ Nil = Refl
> mapSndMapCrossAnyIdLemma f ((a, b) :: abs) =
>     ( map snd (map (cross f id) ((a, b) :: abs)) )
>   ={ Refl }=
>     ( map snd ((f a, b) :: map (cross f id) abs) )
>   ={ Refl }=
>     ( b :: map snd (map (cross f id) abs) )
>   ={ cong (mapSndMapCrossAnyIdLemma f abs) }=
>     ( b :: map snd abs )
>   ={ Refl }=
>     ( map snd ((a, b) :: abs) )
>   QED

* Properties of |length|:

> |||
> lengthLemma : {A, B, C : Type} ->
>               (as : List A) -> (f : A -> B) -> (g : A -> C) ->
>               length (map f as) = length (map g as)
> lengthLemma  Nil      f g = Refl
> lengthLemma (a :: as) f g = ( length (map f (a :: as)) )
>                           ={ Refl }=
>                             ( length (f a :: map f as) )
>                           ={ Refl }=
>                             ( S (length (map f as)) )
>                           ={ cong (lengthLemma as f g) }=
>                             ( S (length (map g as)) )
>                           ={ Refl }=
>                             ( length (g a :: map g as) )
>                           ={ Refl }=
>                             ( length (map g (a :: as)) )
>                           QED

> |||
> lengthConsLemma : {A, B : Type} ->
>                   (a : A) -> (b : B) -> (as : List A) -> (bs : List B) ->
>                   length (a :: as) = length (b :: bs) -> length as = length bs
> lengthConsLemma a b as bs prf = succInjective (length as) (length bs) s2 where
>   s1 : length (a :: as) = length (b :: bs)
>   s1 = prf
>   s2 : S (length as) = S (length bs)
>   s2 = replace2 {P = \ X => \ Y => X = Y} Refl Refl s1

> |||
> lengthReplicateLemma : {A : Type} ->
>                        (n : Nat) -> (a : A) ->
>                        length (replicate n a) = n
> lengthReplicateLemma  Z    _ = Refl
> lengthReplicateLemma (S m) a = ( length (replicate (S m) a) )
>                              ={ Refl }=
>                                ( length (a :: replicate m a) )
>                              ={ Refl }=
>                                ( S (length (replicate m a)) )
>                              ={ cong (lengthReplicateLemma m a) }=
>                                ( S m )
>                              QED

* Properties of |zip| and |unzip|:

> |||
> unzipConsLemma : {A, B : Type} ->
>                  (ab : (A, B)) -> (abs : List (A, B)) ->
>                  unzip (ab :: abs) = (fst ab :: fst (unzip abs), snd ab :: snd (unzip abs))
> unzipConsLemma (a, b) abs with (unzip abs)
>   | (_, _) = Refl

> |||
> fstUnzipConsLemma : {A, B : Type} ->
>                     (ab : (A, B)) -> (abs : List (A, B)) ->
>                     fst (unzip (ab :: abs)) = fst ab :: fst (unzip abs)
> fstUnzipConsLemma ab abs = cong {f = fst} (unzipConsLemma ab abs)

> |||
> sndUnzipConsLemma : {A, B : Type} ->
>                     (ab : (A, B)) -> (abs : List (A, B)) ->
>                     snd (unzip (ab :: abs)) = snd ab :: snd (unzip abs)
> sndUnzipConsLemma ab abs = cong {f = snd} (unzipConsLemma ab abs)

> |||
> unzipZipLemma : {A, B : Type} ->
>                 (as : List A) -> (bs : List B) -> length as = length bs ->
>                 unzip (zip as bs) = (as, bs)
> unzipZipLemma  Nil       Nil      _   = Refl
> unzipZipLemma  Nil      (b :: bs) prf = absurd prf
> unzipZipLemma (a :: as)  Nil      prf = absurd (sym prf)
> unzipZipLemma (a :: as) (b :: bs) prf with (unzip (zip as bs)) proof p
>   | (left, right) = s4 where
>       s1 : length as = length bs
>       s1 = lengthConsLemma a b as bs prf
>       s2 : unzip (zip as bs) = (as, bs)
>       s2 = unzipZipLemma as bs s1
>       s3 : (left, right) = (as, bs)
>       s3 = trans p s2
>       s4 : (a :: left, b :: right) = (a :: as, b :: bs)
>       s4 = replace2 {P = \ X => \ Y => (a :: left, b :: right) = (a :: X, b :: Y)}
>                     (cong {f = fst} s3) (cong {f = snd} s3) Refl

> |||
> sumMapSndUnzipLemma : {A, B : Type} -> (Num B) =>
>                       (abs : List (A, B)) -> sumMapSnd abs = sum (snd (unzip abs))
> sumMapSndUnzipLemma  Nil        = Refl
> sumMapSndUnzipLemma (ab :: abs) =
>     ( sumMapSnd (ab :: abs) )
>   ={ Refl }=
>     ( sum (map snd (ab :: abs)) )
>   ={ Refl }=
>     ( sum (snd ab :: map snd abs) )
>   ={ Refl }=
>     ( snd ab + sum (map snd abs) )
>   ={ Refl }=
>     ( snd ab + sumMapSnd abs )
>   ={ cong (sumMapSndUnzipLemma abs) }=
>     ( snd ab + sum (snd (unzip abs)) )
>   ={ Refl }=
>     ( sum (snd ab :: snd (unzip abs)) )
>   ={ cong (sym (sndUnzipConsLemma ab abs)) }=
>     ( sum (snd (unzip (ab :: abs))) )
>   QED

* Properties of |fold|:

> foldrListLemma : {A, B : Type} ->
>                  (f : A -> B -> B) -> (e : B) ->
>                  (a : A) -> (as : List A) ->
>                  foldr f e (a :: as) = f a (foldr f e as)
> foldrListLemma f e a as = Refl

* Properties of |sum| (for lists of types which are refinements of |Num|):

> |||
> sumSingletonLemma : {A : Type} -> (NumPlusZeroNeutral A) => (x : A) -> sum [x] = x
> sumSingletonLemma x = ( x + 0 )
>                     ={ plusZeroRightNeutral x }=
>                       ( x )
>                     QED

> |||
> sumPlusAppendLemma : {B : Type} -> (NumPlusAssociative B) =>
>                      (xs : List B) -> (ys : List B) ->
>                      (sum xs + sum ys) = sum (xs ++ ys)
> sumPlusAppendLemma Nil       ys = plusZeroLeftNeutral (sum ys)
> sumPlusAppendLemma (x :: xs) ys =
>     ( sum (x :: xs) + sum ys )
>   ={ Refl }=
>     ( (x + sum xs) + sum ys )
>   ={ sym (plusAssociative x (sum xs) (sum ys)) }=
>     ( x + (sum xs + sum ys) )
>   ={ cong (sumPlusAppendLemma xs ys) }=
>     ( x + sum (xs ++ ys) )
>   ={ Refl }=
>     ( sum (x :: (xs ++ ys)) )
>   ={ Refl }=
>     ( sum ((x :: xs) ++ ys) )
>   QED

> |||
> sumConcatLemma : {B : Type} -> (NumPlusAssociative B) =>
>                  (bss : List (List B)) ->
>                  sum (map sum bss) = sum (concat bss)
> sumConcatLemma  Nil        = Refl
> sumConcatLemma (bs :: bss) =
>     ( sum (map sum (bs :: bss)) )
>   ={ Refl }=
>     ( sum (sum bs :: map sum bss) )
>   ={ Refl }=
>     ( sum bs + sum (map sum bss) )
>   ={ cong (sumConcatLemma bss) }=
>     ( sum bs + sum (concat bss) )
>   ={ sumPlusAppendLemma bs (concat bss) }=
>     ( sum (bs ++ concat bss) )
>   ={ Refl }=
>     ( sum (concat (bs :: bss)) )
>   QED

> |||
> sumMapSndNilLemma : {A, B : Type} -> (Num B) => sumMapSnd {A} {B} Prelude.List.Nil = fromInteger 0
> sumMapSndNilLemma = Refl

> |||
> sumMapSndSingletonLemma : {A, B : Type} -> (NumPlusZeroNeutral B) =>
>                           (a : A) -> (b : B) -> sumMapSnd [(a, b)] = b
> sumMapSndSingletonLemma a b = ( sumMapSnd [(a, b)] )
>                             ={ Refl }=
>                               ( sum (map snd [(a, b)]) )
>                             ={ Refl }=
>                               ( sum [b] )
>                             ={ sumSingletonLemma b }=
>                               ( b )
>                             QED

> |||
> sumMapSndConcatLemma : {A, B : Type} -> (NumPlusAssociative B) =>
>                        (abss : List (List (A, B))) ->
>                        sum (map sumMapSnd abss) = sumMapSnd (concat abss)
> sumMapSndConcatLemma  Nil          = Refl
> sumMapSndConcatLemma (abs :: abss) =
>     ( sum (map sumMapSnd (abs :: abss)) )
>   ={ Refl }=
>     ( sum (sumMapSnd abs :: map sumMapSnd abss) )
>   ={ Refl }=
>     ( sum (sum (map snd abs) :: map sumMapSnd abss) )
>   ={ Refl }=
>     ( sum (map snd abs) + sum (map sumMapSnd abss) )
>   ={ cong (sumMapSndConcatLemma abss) }=
>     ( sum (map snd abs) + sumMapSnd (concat abss) )
>   ={ Refl }=
>     ( sum (map snd abs) + sum (map snd (concat abss)) )
>   ={ sumPlusAppendLemma (map snd abs) (map snd (concat abss)) }=
>     ( sum (map snd abs ++ map snd (concat abss)) )
>   ={ cong (sym (mapDistributesOverAppend snd abs (concat abss))) }=
>     ( sum (map snd (abs ++ concat abss)) )
>   ={ Refl }=
>     ( sum (map snd (concat (abs :: abss))) )
>   ={ Refl }=
>     ( sumMapSnd (concat (abs :: abss)) )
>   QED

> |||
> sumMapSndMapIdRightMultLemma : {A, B : Type} -> (Num B) =>
>                                (b : B) -> (ab : (A, B)) -> (abs : List (A, B)) ->
>                                (snd ab) * b + sumMapSnd (mapIdRightMult (abs, b))
>                                =
>                                sumMapSnd (mapIdRightMult ((ab :: abs), b))
> sumMapSndMapIdRightMultLemma b ab abs =
>     ( (snd ab) * b + sumMapSnd (mapIdRightMult (abs, b)) )
>   ={ Refl }=
>     ( (snd ab) * b + sum (map snd (mapIdRightMult (abs, b))) )
>   ={ Refl }=
>     ( sum ((snd ab) * b :: (map snd (mapIdRightMult (abs, b)))) )
>   ={ Refl }=
>     ( sum (snd (fst ab, (snd ab) * b) :: (map snd (mapIdRightMult (abs, b)))) )
>   ={ Refl }=
>     ( sum (snd ((cross id (* b)) (fst ab, snd ab)) :: (map snd (mapIdRightMult (abs, b)))) )
>   ={ cong {f = \ ZUZU => sum (snd ((cross id (* b)) ZUZU) :: (map snd (mapIdRightMult (abs, b))))}
>           (sym (pairLemma ab)) }=
>     ( sum (snd ((cross id (* b)) ab) :: (map snd (mapIdRightMult (abs, b)))) )
>   ={ Refl }=
>     ( sum (snd ((cross id (* b)) ab) :: (map snd (map (cross id (* b)) abs))) )
>   ={ Refl }=
>     ( sum (map snd (((cross id (* b)) ab) :: map (cross id (* b)) abs)) )
>   ={ Refl }=
>     ( sum (map snd (map (cross id (* b)) (ab :: abs))) )
>   ={ Refl }=
>     ( sum (map snd (mapIdRightMult ((ab :: abs), b))) )
>   ={ Refl }=
>     ( sumMapSnd (mapIdRightMult ((ab :: abs), b)) )
>   QED

> |||
> mapIdRightMultLemma : {A, B : Type} -> (NumMultDistributesOverPlus B) =>
>                       (absb : (List (A, B), B)) ->
>                       sumMapSnd (mapIdRightMult absb)
>                       =
>                       (sumMapSnd (fst absb)) * (snd absb)
> mapIdRightMultLemma {A} {B} (Nil, b) =
>     ( sumMapSnd {A} (mapIdRightMult (Nil, b)) )
>   ={ Refl }=
>     ( sumMapSnd {A} (map (cross id (* b)) Nil) )
>   ={ Refl }=
>     ( sumMapSnd {A} Nil )
>   ={ Refl }=
>     ( 0 )
>   ={ sym (multZeroLeftZero b) }=
>     ( 0 * b )
>   ={ Refl }=
>     ( (sumMapSnd {A} Nil) * b )
>   ={ Refl }=
>     ( (sumMapSnd {A} (fst (Nil, b))) * (snd {a = List (A, B)} (Nil, b)) )
>   QED
> mapIdRightMultLemma ((ab :: abs), b) = assert_total (
>     ( sumMapSnd (mapIdRightMult ((ab :: abs), b)) )
>   ={ sym (sumMapSndMapIdRightMultLemma b ab abs) }=
>     ( (snd ab) * b + sumMapSnd (mapIdRightMult (abs, b)) )
>   ={ cong (mapIdRightMultLemma (abs, b)) }=
>     ( (snd ab) * b + (sumMapSnd (fst (abs, b))) * (snd (abs, b)) )
>   ={ Refl }=
>     ( (snd ab) * b + (sumMapSnd abs) * b )
>   ={ sym (multDistributesOverPlusLeft (snd ab) (sumMapSnd abs) b) }=
>     ( (snd ab + sumMapSnd abs) * b )
>   ={ Refl }=
>     ( (snd ab + sum (map snd abs)) * b )
>   ={ Refl }=
>     ( (sumMapSnd (ab :: abs)) * b )
>   ={ Refl }=
>     ( (sumMapSnd (fst ((ab :: abs), b))) * (snd ((ab :: abs), b)) )
>   QED
>   )

> |||
> mvMultLemma : {A, A', B : Type} -> (NumMultDistributesOverPlus B) =>
>               (abs : List (A, B)) -> (f : A -> List (A', B)) -> ((a : A) -> sumMapSnd (f a) = 1) ->
>               sumMapSnd (mvMult abs f) = sumMapSnd abs
> mvMultLemma  Nil        _ _   = Refl
> mvMultLemma (ab :: abs) f prf =
>   let a = fst ab in
>   let b = snd ab in
>   let fid = cross f id in
>   let h = mapIdRightMult . fid in
>     ( sumMapSnd (mvMult (ab :: abs) f) )
>   ={ Refl }=
>     ( sumMapSnd (concat (map h (ab :: abs))) )
>   ={ sym (sumMapSndConcatLemma (map h (ab :: abs))) }=
>     ( sum (map sumMapSnd (map h (ab :: abs))) )
>   ={ Refl }=
>     ( sum (map sumMapSnd (h ab :: map h abs)) )
>   ={ Refl }=
>     ( sum (sumMapSnd (h ab) :: map sumMapSnd (map h abs)) )
>   ={ cong {f = \ ZUZU => sum (ZUZU :: map sumMapSnd (map h abs))} (mapIdRightMultLemma ((cross f id) ab)) }=
>     ( sum ((sumMapSnd (fst (fid ab))) * (snd (fid ab)) :: map sumMapSnd (map h abs)) )
>   ={ cong {f = \ ZUZU => sum ((sumMapSnd (fst (fid ab))) * ZUZU :: map sumMapSnd (map h abs))}
>           (crossAnyIdSndLemma' {ab} {f}) }=
>     ( sum ((sumMapSnd (fst (fid ab))) * (snd ab) :: map sumMapSnd (map h abs)) )
>   ={ cong {f = \ ZUZU => sum ((sumMapSnd ZUZU) * (snd ab) :: map sumMapSnd (map h abs))}
>           (crossAnyIdFstLemma' {ab} {f}) }=
>     ( sum ((sumMapSnd (f a)) * b :: map sumMapSnd (map h abs)) )
>   ={ cong {f = \ ZUZU => sum (ZUZU * b :: map sumMapSnd (map h abs))} (prf a) }=
>     ( sum (1 * b :: map sumMapSnd (map h abs)) )
>   ={ cong {f = \ ZUZU => sum (ZUZU :: map sumMapSnd (map h abs))} (multOneLeftNeutral b) }=
>     ( sum (b :: map sumMapSnd (map h abs)) )
>   ={ Refl }=
>     ( b + sum (map sumMapSnd (map h abs)) )
>   ={ cong (sumMapSndConcatLemma (map h abs)) }=
>     ( b + sumMapSnd (concat (map h abs)) )
>   ={ Refl }=
>     ( b + sumMapSnd (mvMult abs f) )
>   ={ cong (mvMultLemma abs f prf) }=
>     ( b + sumMapSnd abs )
>   ={ Refl }=
>     ( b + sum (map snd abs) )
>   ={ Refl }=
>     ( sum (b :: map snd abs) )
>   ={ Refl }=
>     ( sum (map snd (ab :: abs)) )
>   ={ Refl }=
>     ( sumMapSnd (ab :: abs) )
>   QED

* Ad-hoc filtering

> |||
> discardZeroesLemma : {B : Type} -> (NumPlusZeroNeutral B, DecEq B) =>
>                    (bs : List B) -> sum (discardZeroes bs) = sum bs
> discardZeroesLemma  Nil      = Refl
> discardZeroesLemma (b :: bs) with (decEq b 0)
>   | (Yes p) = ( sum (discardZeroes bs) )
>             ={ discardZeroesLemma bs }=
>               ( sum bs )
>             ={ sym (plusZeroLeftNeutral (sum bs)) }=
>               ( 0 + sum bs )
>             ={ cong {f = \ ZUZU => ZUZU + sum bs} (sym p) }=
>               ( b + sum bs )
>             ={ Refl }=
>               ( sum (b :: bs) )
>             QED
>   | (No _)  = ( sum (b :: discardZeroes bs) )
>             ={ Refl }=
>               ( b + sum (discardZeroes bs) )
>             ={ cong (discardZeroesLemma bs) }=
>               ( b + sum bs )
>             ={ Refl }=
>               ( sum (b :: bs) )
>             QED

> |||
> discardBySndZeroLemma : {A, B : Type} -> (NumPlusZeroNeutral B, DecEq B) =>
>                         (abs : List (A, B)) -> sumMapSnd (discardBySndZero abs) = sumMapSnd abs
> discardBySndZeroLemma  Nil      = Refl
> discardBySndZeroLemma (ab :: abs) with (decEq (snd ab) 0)
>   | (Yes p) = ( sumMapSnd (discardBySndZero abs) )
>             ={ discardBySndZeroLemma abs }=
>               ( sumMapSnd abs )
>             ={ sym (plusZeroLeftNeutral (sumMapSnd abs)) }=
>               ( 0 + sumMapSnd abs )
>             ={ cong {f = \ ZUZU => ZUZU + sumMapSnd abs} (sym p) }=
>               ( (snd ab) + sumMapSnd abs )
>             ={ Refl }=
>               ( sumMapSnd (ab :: abs) )
>             QED
>   | (No _)  = ( sumMapSnd (ab :: discardBySndZero abs) )
>             ={ Refl }=
>               ( (snd ab) + sumMapSnd (discardBySndZero abs) )
>             ={ cong (discardBySndZeroLemma abs) }=
>               ( (snd ab) + sumMapSnd abs )
>             ={ Refl }=
>               ( sumMapSnd (ab :: abs) )
>             QED

> |||
> postulate discardBySndZeroLemmaEq : {A, B : Type} -> (Num B, Eq B) =>
>                                     (abs : List (A, B)) -> sumMapSnd (discardBySndZeroEq abs) = sumMapSnd abs

> |||
> discardBySndZeroLemma1 : {A, B : Type} -> (Num B, DecEq B) =>
>                          (a : A) -> (b : B) -> Not (b = 0) ->
>                          discardBySndZero ((a, b) :: Nil) = (a, b) :: Nil
> discardBySndZeroLemma1 a b contra with (decEq b 0)
>   | (Yes prf) = void (contra prf)
>   | (No _)  = Refl


module Control.Monad.State

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

||| A computation which runs in a context and produces an output
public export
interface Monad m => MonadState stateType (m : Type -> Type) | m where
    ||| Get the context
    get : m stateType
    ||| Write a new context/output
    put : stateType -> m ()

||| The transformer on which the State monad is based
public export
record StateT (stateType : Type) (m : Type -> Type) (a : Type) where
  constructor ST
  runStateT' : stateType -> m (stateType, a)

public export
implementation Functor f => Functor (StateT stateType f) where
    map f (ST g) = ST (\st => map (map f) (g st)) where

public export
implementation Monad f => Applicative (StateT stateType f) where
    pure x = ST (\st => pure (st, x))

    (ST f) <*> (ST a)
        = ST (\st =>
                do (r, g) <- f st
                   (t, b) <- a r
                   pure (t, g b))

public export
implementation Monad m => Monad (StateT stateType m) where
    (ST f) >>= k
        = ST (\st =>
                do (st', v) <- f st
                   let ST kv = k v
                   kv st')

public export
implementation Monad m => MonadState stateType (StateT stateType m) where
    get   = ST (\x => pure (x, x))
    put x = ST (\y => pure (x, ()))

public export
implementation MonadTrans (StateT stateType) where
    lift x
        = ST (\st =>
                do r <- x
                   pure (st, r))

public export
implementation (Monad f, Alternative f) => Alternative (StateT st f) where
    empty = lift empty
    (ST f) <|> (ST g) = ST (\st => f st <|> g st)

public export
implementation HasIO m => HasIO (StateT stateType m) where
  liftIO io = ST $ \s => liftIO $ io_bind io $ \a => pure (s, a)

||| Apply a function to modify the context of this computation
public export
modify : MonadState stateType m => (stateType -> stateType) -> m ()
modify f
    = do s <- get
         put (f s)

||| Evaluate a function in the context held by this computation
public export
gets : MonadState stateType m => (stateType -> a) -> m a
gets f
    = do s <- get
         pure (f s)

||| Unwrap and apply a StateT monad computation.
public export
%inline
runStateT : stateType -> StateT stateType m a -> m (stateType, a)
runStateT s act = runStateT' act s

||| The State monad. See the MonadState interface
public export
State : (stateType : Type) -> (ty : Type) -> Type
State = \s, a => StateT s Identity a

||| Unwrap and apply a State monad computation.
public export
runState : stateType -> StateT stateType Identity a -> (stateType, a)
runState s act = runIdentity (runStateT s act)

||| Unwrap and apply a State monad computation, but discard the final state.
public export
evalState : stateType -> State stateType a -> a
evalState s = snd . runState s

||| Unwrap and apply a State monad computation, but discard the resulting value.
public export
execState : stateType -> State stateType a -> stateType
execState s = fst . runState s


{- Ctrl-Alt-A: Add definition
   Ctrl-Alt-C: Case split
   Ctrl-Alt-D: Documentation
   Ctrl-Alt-L: Lift hole: Lifts a hole to the top level as a new function definition
   Ctrl-Alt-M: Match: Replaces a hole with a case expression that matches on an intermediate result
   Ctrl-Alt-R: Reloads and typechecks the current buffer
   Ctrl-Alt-S: Search
   Ctrl-Alt-T: Type-check: Displays the type under cursor -}
module Main

import Data.Vect

data WorldState : (guesses_remaning : Nat) -> (letters : Nat) -> Type where
  MkWorldState : (word : String) ->
                 (missing : Vect letters Char) ->
                 WorldState guesses_remaning letters

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

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

isValidNil : ValidInput [] -> Void
isValidNil (Letter _) impossible

isValidMore : ValidInput (x :: (y :: ys)) -> Void
isValidMore (Letter _) impossible

isValidInput : (cs : List Char) -> Dec (ValidInput cs)
isValidInput [] = No isValidNil
isValidInput (x :: []) = Yes (Letter x)
isValidInput (x :: (y :: ys)) = No isValidMore

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

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 : (letter : Char) ->
               WorldState (S guesses) (S letters) ->
               Either (WorldState guesses (S letters))
                      (WorldState (S guesses) letters)
processGuess letter (MkWorldState word missing) = case isElem letter missing of
  (Yes elem) => Right (MkWorldState word (dropElem missing elem))
  (No contra) => Left (MkWorldState word missing)

game : WorldState (S guesses) (S letters) -> IO Finished
game {guesses} {letters} st = do
  (_ ** Letter letter) <- readGuess
  case processGuess letter st of
    Left badGuess => do putStrLn "Wrong!"
                        case guesses of
                          Z => pure (Lost badGuess)
                          S _ => game badGuess
    Right goodGuess => do putStrLn "Right!"
                          case letters of
                            Z => pure (Won goodGuess)
                            S _ => game goodGuess

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


module Main

import Data.Vect
import Data.Fin
import Unification

f : Term (Fin 2)
f = identifier (MkName "f")

c : Term (Fin 2)
c = identifier (MkName "c")

cc : Term (Fin 2)
cc = app c c

x : Term (Fin 2)
x = var 0

y : Term (Fin 2)
y = var 1

unifyXY : Maybe (Exists (SubstList 2))
unifyXY = unify x y

unifyXFCC : Maybe (Exists (SubstList 2))
unifyXFCC = unify x (app f cc)

toNatPair : Fin n -> (Nat, Nat)
toNatPair (FZ {k=k}) = (1, S k)
toNatPair (FS i {k=k}) = (1 + fst (toNatPair i), S k)

Show (Fin n) where
  showPrec d i = case toNatPair i of
    (i, n) => showCon d "Fin" (" " ++ show i ++ "/" ++ show n)

Show n => Show (Term n) where
  showPrec d = fold
    (\i => showCon d "Var" (showArg i))
    (\c => case c of (MkName n) => showCon d "Identifier" (showArg n))
    (\l, r => showCon d "App" (" " ++ l ++ " " ++ r))

Show (Subst m) where
  showPrec d (MkSubst x t) = showCon d "Subst" ((showArg x) ++ (showArg t))

Show (SubstList m n) where
  show Nil = "[]"
  show (s :: ss) = (show s) ++ " :: " ++ (show ss)

Show (Exists (SubstList n)) where
  show (Evidence _ ss) = show ss

main : IO ()
main = do
  printLn unifyXY
  printLn $ unify (app f (app f c)) (app f y)
  printLn unifyXFCC


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

import public Chapter.State

%access export

-- -------------------------------------------------------- [ 12.1.5 Exercises ]

update : (stateType -> stateType) -> State stateType ()
update = (get >>=) . (put .)

increase : Nat -> State Nat ()
increase = update . (+)

%hide Chapter.State.increase

countEmpty : Tree a -> State Nat ()
countEmpty  Empty              = increase 1
countEmpty (Node left _ right) = countEmpty left *> countEmpty right

-- Like Bifunctor.first for Pair.
private
first : (a -> c) -> (a, b) -> (c, b)
first f (a, b) = (f a, b)

-- Like Bifunctor.second for Pair.
private
second : (b -> d) -> (a, b) -> (a, d)
second g (a, b) = (a, g b)

countEmptyNode : Tree a -> State (Nat, Nat) ()
countEmptyNode Empty               = update (first S)
countEmptyNode (Node left _ right) = countEmptyNode left  *>
                                     countEmptyNode right *>
                                     update (second S)

-- -------------------------------------------------------- [ 12.3.7 Exercises ]

export
updateGameState : (GameState -> GameState) -> Command ()
updateGameState f = GetGameState >>= PutGameState . f

public export
implementation Functor Command where
  map f x = Bind x (Pure . f)

public export
implementation Applicative Command where
  pure = Pure
  f <*> m = Bind f $ (Bind m) . (Pure .)

public export
implementation Monad Command where
  (>>=) = Bind

public export
record Votes where
  constructor MkVotes
  upvotes, downvotes : Integer

public export
record Article where
  constructor MkArticle
  title, url : String
  score : Votes

export
initPage : (title, url : String) -> Article
initPage title url = MkArticle title url (MkVotes 0 0)

export
getScore : Article -> Integer
getScore = (\(MkVotes up down) => up - down) . score

export
addUpvote : Article -> Article
addUpvote = record { score->upvotes $= (+1) }

export
addDownvote : Article -> Article
addDownvote = record { score->downvotes $= (+1) }

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


import Stuff

interface Functor f where
    map : (a -> b) -> f a -> f b

Functor List where
  map f [] = []
  map f (x :: xs) = f x :: map f xs

data Test : Type -> Type -> Type -> Type where
     MkTest : a -> b -> c -> Test a b c

Functor (Test c d) where
  map = ?foo

-- Checking we can cope with the clash between the a,b here and the
-- a,b in 'map' (the names here get priority, and the ones in map get
-- renamed)
Functor (Test a b) where
  map = ?bar


module Main

import Effect.State

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

flattenTree : Tree a -> List a
flattenTree Leaf = []
flattenTree (Node l x r) = flattenTree l ++ (x :: flattenTree r)

testTree : Tree String
testTree = Node (Node Leaf "One" (Node Leaf "Two" Leaf))
                "Three"
                (Node (Node Leaf "Four" Leaf) "Five" Leaf)

data Tag : Type where
data Leaves : Type where

label : Tree a -> { [STATE Int] } Eff m (Tree (Int, a))
label Leaf = return Leaf
label (Node l x r) = do l' <- label l
                        lbl <- get
                        put (lbl + 1)
                        r' <- label r
                        return (Node l' (lbl, x) r')

main : IO ()
main = do let t = runPure (do put 1; label testTree)
          print (flattenTree t)

{-
label Leaf = return Leaf
label (Node l x r) = do l' <- label l
                        lbl <- get
                        put (lbl + 1)
                        r' <- label r
                        return (Node l' (lbl, x) r')
-}


module DataStructures

%access public export
data BBinOp = And | Or
Show BBinOp where
  show And = "AND"
  show Or = "OR"

data RBinOp = Greater | Less
Show RBinOp where
  show Greater = "GREATER"
  show Less = "LESS"

data ABinOp = Add
            | Subtract
            | Multiply
            | Divide
Show ABinOp where
  show Add = "ADD"
  show Subtract = "SUBTRACT"
  show Multiply = "MULTIPLY"
  show Divide = "DIVIDE"

data AExpr = Var String
           | IntConst Integer
           | Neg AExpr
           | ABinary ABinOp AExpr AExpr
Show AExpr where
  show (Var a) = "(VAR " ++ a ++ ")"
  show (IntConst i) = "(INTCONST " ++ (show i) ++ ")"
  show (Neg a) = "(NEG " ++ (show a) ++ ")"
  show (ABinary o l r) = "(ABINARY (" ++ (show o) ++ " " ++ (show l) ++ (show r) ++ "))"

data BExpr = BoolConst Bool
           | BNot BExpr
           | BBinary BBinOp BExpr BExpr
           | RBinary RBinOp AExpr AExpr
Show BExpr where
  show (BoolConst b) = "(BOOLCONST " ++ (show b) ++ ")"
  show (BNot b) = "(BNOT " ++ (show b) ++ ")"
  show (BBinary o l r) = "(BBINARY (" ++ (show o) ++ " " ++ (show l) ++ (show r) ++ "))"
  show (RBinary o l r) = "(RBINARY (" ++ (show o) ++ " " ++ (show l) ++ (show r) ++ "))"

data Stmt = Seq (List Stmt)
          | Assign AExpr AExpr
          | If BExpr Stmt Stmt
          | While BExpr Stmt
          | Skip
Show Stmt where
  show (Seq x) = concatMap (\s => show s ++ "\n") x ++ ")"
  show (Assign s a) = "(ASSIGN " ++ (show s) ++ (show a) ++ ")"
  show (If b t f) = "(IF " ++ (show b) ++ (show t) ++ (show f) ++ ")"
  show (While b s) = "(While " ++ (show b) ++ (show s) ++ ")"
  show Skip = "(SKIP" ++ ")"


module Blackbird

import Data.Nat

f : Nat -> Nat -> Nat
f = (+1) .: (+) . (+1)

g : Nat -> Nat -> Nat
-- instead of `g = (+1) . (+1) .: (+)` write, since double `.:` works for any priority and "`.` then `.:`" works only when `.:` has smaller priority.
g = (+1) .: (+1) .: (+)

-- Assumes that `.:` has the same priority as `.`
x : String -> List String -> String
x = concatMap . (++ "e") .: (++) . (++ "x")


> module SequentialDecisionProblems.Utils

> import Data.Fin
> import Control.Isomorphism

> import SequentialDecisionProblems.CoreTheory

> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Sigma.Sigma
> import Sigma.Operations
> import Sigma.Properties
> import Fun.Operations
> import Decidable.Predicates
> import Decidable.Properties

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

* Finiteness notions

> |||
> FiniteViable : Type
> FiniteViable = {t : Nat} ->
>                (n : Nat) -> (x : State t) -> Finite (Viable {t} n x)

> |||
> FiniteAll : Type
> FiniteAll = {A : Type} -> {P : A -> Type} ->
>             Finite1 P -> (ma : M A) -> Finite (All P ma)

> |||
> FiniteAllViable : Type
> FiniteAllViable = {t : Nat} ->
>                   (n : Nat) -> (mx : M (State t)) -> Finite (All (Viable n) mx)

> |||
> FiniteNotEmpty : Type
> FiniteNotEmpty = {A : Type} ->
>                  (ma : M A) -> Finite (NotEmpty ma)

> |||
> FiniteGood : Type
> FiniteGood = {t : Nat} -> {n : Nat} ->
>              (x : State t) -> (y : Ctrl t x) ->
>              Finite (Good t x n y)

> |||
> FiniteCtrl : Type
> FiniteCtrl = {t : Nat} ->
>              (x : State t) -> Finite (Ctrl t x)

> |||
> FiniteGoodCtrl : Type
> FiniteGoodCtrl = {t : Nat} -> {n : Nat} ->
>                  (x : State t) -> Viable {t = t} (S n) x ->
>                  Finite (GoodCtrl t x n)

* Decidability notions

> |||
> DecidableViable : Type
> DecidableViable = {t : Nat} ->
>                   (n : Nat) -> (x : State t) -> Dec (Viable {t} n x)

> |||
> DecidableAll : Type
> DecidableAll = {A : Type} -> {P : A -> Type} ->
>                Dec1 P -> (ma : M A) -> Dec (All P ma)

> |||
> DecidableAllViable : Type
> DecidableAllViable = {t : Nat} ->
>                      (n : Nat) -> (mx : M (State t)) -> Dec (All (Viable n) mx)

> |||
> DecidableNotEmpty : Type
> DecidableNotEmpty = {A : Type} ->
>                     (ma : M A) -> Dec (NotEmpty ma)

> |||
> DecidableGood : Type
> DecidableGood = {t : Nat} -> {n : Nat} ->
>                 (x : State t) -> (y : Ctrl t x) ->
>                 Dec (Good t x n y)

> |||
> DecidableGoodCtrl : Type
> DecidableGoodCtrl = {t : Nat} -> {n : Nat} ->
>                     (x : State t) -> Viable {t = t} (S n) x ->
>                     Dec (GoodCtrl t x n)

* Standard deduction patterns in the implementation of specific SDPs

We would like to provide users with a function

< finiteAllViable : FiniteAll -> FiniteViable -> FiniteAllViable

but, as it turns out, implementing this function is not trivial (see
issues 3135 and 3136). Thus, for the time being, we introduce 2
additional assumptions in the global context. If users can prove that
|All| is finite

> |||
> finiteAll : {A : Type} -> {P : A -> Type} ->
>             Finite1 P -> (ma : M A) -> Finite (All P ma)

and that |Viable| is finite,

> |||
> finiteViable : {t : Nat} ->
>                (n : Nat) -> (x : State t) -> Finite (Viable n x)

we deduce finiteness of |All Viable|:

> |||
> finiteAllViable : {t : Nat} ->
>                   (n : Nat) -> (mx : M (State t)) -> Finite (All (Viable n) mx)
> finiteAllViable n mx = finiteAll (finiteViable n) mx

Similarly, if users are able to prove that |NotEmpty| is finite

> finiteNotEmpty : {t : Nat} ->
>                  (mx : M (State t)) -> Finite (NotEmpty mx)

we can deduce finiteness of |Good|

> |||
> finiteGood : {t : Nat} ->
>              (n : Nat) -> (x : State t) ->
>              (y : Ctrl t x) -> Finite (Good t x n y)
> finiteGood {t} n x y = finiteProduct (finiteNotEmpty  {t = S t}   (nexts t x y ))
>                                      (finiteAllViable {t = S t} n (nexts t x y ))

and, assuming finiteness of controls, finiteness of |GoodCtrl|

> |||
> finiteCtrl : {t : Nat} -> (x : State t) -> Finite (Ctrl t x)

, finiteness of good controls:

> |||
> finiteGoodCtrl : {t : Nat} ->
>                  (n : Nat) -> (x : State t) -> Finite (GoodCtrl t x n)
> finiteGoodCtrl n x = finiteSigmaLemma0 (finiteCtrl x) (finiteGood n x)

Finally, we can show that, for states which are viable for more than
zero steps, good controls are not empty:

> |||
> cardNotZGoodCtrl : {t : Nat} ->
>                    (n : Nat) -> (x : State t) -> (v : Viable {t = t} (S n) x) ->
>                    CardNotZ (finiteGoodCtrl {t} n x)
> cardNotZGoodCtrl n x v = cardNotZLemma (finiteGoodCtrl n x) (viableSpec1 x v)

Similarly, we can provide standard deduction patterns for
decidability. If users can prove that |All| is decidable

> |||
> decidableAll : {A : Type} -> {P : A -> Type} ->
>                ((a : A) -> Dec (P a)) -> (ma : M A) -> Dec (All P ma)

and that |Viable| is decidable

> |||
> decidableViable : {t : Nat} ->
>                   (n : Nat) -> (x : State t) -> Dec (Viable n x)

we can deduce decidability of |All Viable|:

> |||
> decidableAllViable : {t : Nat} ->
>                      (n : Nat) -> (mx : M (State t)) -> Dec (All (Viable n) mx)
> decidableAllViable n mx = decidableAll (decidableViable n) mx

Further, if users are able to prove that |NotEmpty| is decidable

> |||
> decidableNotEmpty : {t : Nat} ->
>                     (mx : M (State t)) -> Dec (NotEmpty mx)

we can deduce decidability of |Good|

> |||
> decidableGood : {t : Nat} ->
>                 (n : Nat) -> (x : State t) ->
>                 (y : Ctrl t x) -> Dec (Good t x n y)
> decidableGood {t} n x y = decPair (decidableNotEmpty  {t = S t}   (nexts t x y))
>                                   (decidableAllViable {t = S t} n (nexts t x y))

and, assuming finiteness of controls, decidability of |GoodCtrl|:

> |||
> decidableGoodCtrl : {t : Nat} ->
>                     (n : Nat) -> (x : State t) -> Dec (GoodCtrl t x n)
> decidableGoodCtrl n x = finiteDecSigmaLemma (finiteCtrl x) (decidableGood n x)

We apply these patterns, for instance, in |ViabilityDefaults|.

* Show states and controls

> |||
> showState : {t : Nat} -> State t -> String

> |||
> showCtrl : {t : Nat} -> {x : State t} -> Ctrl t x -> String

> |||
> showStateCtrl : {t : Nat} -> Sigma (State t) (Ctrl t) -> String
> showStateCtrl {t} (MkSigma x y) = "(" ++ showState {t} x ++ " ** " ++ showCtrl {t} {x} y ++ ")"

* Sequences of state-control pairs

> |||
> data StateCtrlSeq : (t : Nat) -> (n : Nat) -> Type where
>   Nil   :  {t : Nat} -> (x : State t) -> StateCtrlSeq t Z
>   (::)  :  {t, n : Nat} -> Sigma (State t) (Ctrl t) -> StateCtrlSeq (S t) n -> StateCtrlSeq t (S n)

> using (t : Nat, n : Nat)
>   implementation Show (StateCtrlSeq t n) where
>     show = show' where
>       show' : {t : Nat} -> {n : Nat} -> StateCtrlSeq t n -> String
>       show' xys = "[" ++ show'' "" xys ++ "]" where
>         show'' : {t' : Nat} -> {n' : Nat} -> String -> StateCtrlSeq t' n' -> String
>         show'' {t'} {n' = Z}    acc (Nil x)     =
>           acc ++ "(" ++ showState x ++ " ** " ++ " " ++ ")"
>         show'' {t'} {n' = S m'} acc (xy :: xys) =
>           show'' {t' = S t'} {n' = m'} (acc ++ showStateCtrl xy ++ ", ") xys

> |||
> valStateCtrlSeq : (t : Nat) -> (n : Nat) -> StateCtrlSeq t n -> Val
> valStateCtrlSeq t       Z   (Nil x) =
>   zero
> valStateCtrlSeq t    (S Z)  ((MkSigma x y) :: (Nil x')) =
>   reward t x y x'
> valStateCtrlSeq t (S (S m)) ((MkSigma x y) :: (MkSigma x' y') :: xys) =
>   reward t x y x' `plus` valStateCtrlSeq (S t) (S m) ((MkSigma x' y') :: xys)

* Trajectories

> ||| The monadic operations
> ret   :  {A : Type} -> A -> M A
> bind  :  {A, B : Type} -> M A -> (A -> M B) -> M B
> postulate monadSpec1   :  {A, B : Type} -> {f : A -> B} ->
>                           (fmap f) . ret = ret . f
> postulate monadSpec21  :  {A, B : Type} -> {f : A -> M B} -> {a : A} ->
>                           bind (ret a) f = f a
> postulate monadSpec22  :  {A : Type} -> {ma : M A} ->
>                           bind ma ret = ma
> postulate monadSpec23  :  {A, B, C : Type} -> {f : A -> M B} -> {g : B -> M C} -> {ma : M A} ->
>                           bind (bind ma f) g = bind ma (\ a => bind (f a) g)

> |||
> possibleStateCtrlSeqs  :  {t, n : Nat} -> (x : State t) -> (r : Reachable x) -> (v : Viable n x) ->
>                           (ps : PolicySeq t n) -> M (StateCtrlSeq t n)
> possibleStateCtrlSeqs {t} {n = Z}    x r v Nil         =  ret (Nil x)
> {-
> possibleStateCtrlSeqs {t} {n = S m}  x r v (p :: ps')  =
>   fmap g (bind (tagElem mx') f) where
>     y   :  Ctrl t x
>     y   =  ctrl (p x r v)
>     mx' :  M (State (S t))
>     mx' =  nexts t x y
>     av  :  All (Viable m) mx'
>     av  =  allViable (p x r v)
>     g   :  StateCtrlSeq (S t) m -> StateCtrlSeq t (S m)
>     g   =  ((MkSigma x y) ::)
>     f   :  Sigma (State (S t)) (\ x' => x' `Elem` mx') -> M (StateCtrlSeq (S t) m)
>     f (MkSigma x' x'emx') = possibleStateCtrlSeqs {n = m} x' r' v' ps' where
>       ar  :  All Reachable mx'
>       ar  =  reachableSpec1 x r y
>       r'  :  Reachable x'
>       r'  =  allElemSpec0 x' mx' ar x'emx'
>       v'  :  Viable m x'
>       v'  =  allElemSpec0 x' mx' av x'emx'
> -}
> possibleStateCtrlSeqs {t} {n = S m}  x r v (p :: ps')  =
>   let y   :  Ctrl t x
>           =  ctrl (p x r v) in
>   let mx' :  M (State (S t))
>           =  nexts t x y in
>   let av  :  All (Viable m) mx'
>           =  allViable (p x r v) in
>   let g   :  (StateCtrlSeq (S t) m -> StateCtrlSeq t (S m))
>           =  ((MkSigma x y) ::) in
>   let ar  :  All Reachable mx'
>           =  reachableSpec1 x r y in
>   let r'  :  ((x' : State (S t)) -> x' `Elem` mx' -> Reachable x')
>           =  \ x' => \ x'emx' => allElemSpec0 x' mx' ar x'emx' in
>   let v'  :  ((x' : State (S t)) -> x' `Elem` mx' -> Viable m x')
>           =  \ x' => \ x'emx' => allElemSpec0 x' mx' av x'emx' in
>   let f   :  (Sigma (State (S t)) (\ x' => x' `Elem` mx') -> M (StateCtrlSeq (S t) m))
>           =  \ (MkSigma x' x'emx') => possibleStateCtrlSeqs {n = m} x' (r' x' x'emx') (v' x' x'emx') ps' in
>   fmap g (bind (tagElem mx') f)

> |||
> morePossibleStateCtrlSeqs  :  {t, n : Nat} -> (mx : M (State t)) ->
>                               All Reachable mx -> All (Viable n) mx ->
>                               (ps : PolicySeq t n) -> M (StateCtrlSeq t n)
> morePossibleStateCtrlSeqs {t} {n}  mx ar av ps  =  bind (tagElem mx) f where
>   f : Sigma (State t) (\ x => x `Elem` mx) -> M (StateCtrlSeq t n)
>   f (MkSigma x xemx) = possibleStateCtrlSeqs x r v ps where
>       r  :  Reachable x
>       r  =  allElemSpec0 x mx ar xemx
>       v  :  Viable n x
>       v  =  allElemSpec0 x mx av xemx

> |||
> possibleStateCtrlSeqsRewards : {t : Nat} -> {n : Nat} ->
>                                (x : State t) -> (r : Reachable x) -> (v : Viable n x) ->
>                                (ps : PolicySeq t n) -> M (StateCtrlSeq t n, Val)
> possibleStateCtrlSeqsRewards {t} {n} x r v ps =
>   fmap (pair (id, valStateCtrlSeq t n)) (possibleStateCtrlSeqs {t} {n} x r v ps)

> |||
> possibleStateCtrlSeqsRewards' : {t : Nat} -> {n : Nat} ->
>                                 M (StateCtrlSeq t n) -> M (StateCtrlSeq t n, Val)
> possibleStateCtrlSeqsRewards' {t} {n} xys = fmap (pair (id, valStateCtrlSeq t n)) xys

> |||
> possibleRewards : {t : Nat} -> {n : Nat} ->
>                   (x : State t) -> (r : Reachable x) -> (v : Viable n x) ->
>                   (ps : PolicySeq t n) -> M Val
> possibleRewards {t} {n} x r v ps =
>   fmap (valStateCtrlSeq t n) (possibleStateCtrlSeqs {t} {n} x r v ps)

> |||
> possibleRewards' : {t : Nat} -> {n : Nat} -> M (StateCtrlSeq t n) -> M Val
> possibleRewards' {t} {n} xys = fmap (valStateCtrlSeq t n) xys

* Computation of specific trajectories via selection function

> {-
> |||
> stateCtrlSeq : {t, n : Nat} ->
>                (x : State t) -> (r : Reachable x) -> (v : Viable n x) ->
>                (ps : PolicySeq t n) ->
>                (eps : {A : Type} -> M A -> A) ->
>                StateCtrlSeq t n
> stateCtrlSeq {t} {n = Z}    x r v Nil        eps =  Nil x
> stateCtrlSeq {t} {n = S m}  x r v (p :: ps') eps =
>   (MkSigma x y) :: (eps (fmap f (tagElem mx'))) where
>     y   :  Ctrl t x
>     y   =  ctrl (p x r v)
>     mx' :  M (State (S t))
>     mx' =  nexts t x y
>     av  :  All (Viable m) mx'
>     av  =  allViable (p x r v)
>     f   :  Sigma (State (S t)) (\ x' => x' `Elem` mx') -> StateCtrlSeq (S t) m
>     f (MkSigma x' x'emx') = res where -- stateCtrlSeq {t = S t} {n = m} x' r' v' ps' eps where
>       ar  :  All Reachable mx'
>       ar  =  reachableSpec1 x r y
>       r'  :  Reachable x'
>       r'  =  allElemSpec0 x' mx' ar x'emx'
>       v'  :  Viable m x'
>       v'  =  allElemSpec0 x' mx' av x'emx'
>       res :  StateCtrlSeq (S t) m
>       res =  ?kika
> -}

* Alternative computation of trajectories

> |||
> app : {t, m, n : Nat} ->
>       StateCtrlSeq t m -> Policy (t + m) (S n) -> M (StateCtrlSeq t (S m))
> app {t} {m = Z} {n} (Nil {t} x) p = fmap (f . g) (nexts t x y) where
>   postulate r : Reachable x
>   postulate v : Viable (S n) x
>   q : Policy t (S n)
>   q = replace {P = \ X => Policy X (S n)} (plusZeroRightNeutral t) p
>   y : Ctrl t x
>   y = ctrl (q x r v)
>   f : StateCtrlSeq (S t) Z -> StateCtrlSeq t (S Z)
>   f nx' = (MkSigma x y) :: nx'
>   g : State (S t) -> StateCtrlSeq (S t) Z
>   g x' = Nil x'
> app {t} {m = S m'} {n} (xy :: xys) p = fmap f (app xys q) where
>   f : StateCtrlSeq (S t) (S m') -> StateCtrlSeq t (S (S m'))
>   f = (xy ::)
>   q : Policy (S t + m') (S n)
>   q = replace {P = \ X => Policy X (S n)} (sym (plusSuccRightSucc t m')) p

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

> possibleStateCtrlSeqs1 : {t, n : Nat} -> (x : State t) -> (r : Reachable x) -> (v : Viable n x) ->
>                          (ps : PolicySeq t n) -> M (StateCtrlSeq t n)
> possibleStateCtrlSeqs1 {t} {n} x r v ps = s2 where
>   s1 : M (StateCtrlSeq t (Z + n))
>   s1 = extend (ret (Nil {t} x)) (replace {P = \ X => PolicySeq X n} (sym (plusZeroRightNeutral t)) ps)
>   s2 : M (StateCtrlSeq t n)
>   s2 = replace {P = \ X => M (StateCtrlSeq t X)} (plusZeroLeftNeutral n) s1

> {-

> ---}


module DepPairs

import Data.Vect

%default total

partial
readVect : HasIO io => io (n : Nat ** Vect n String)
readVect = do x <- getLine
              if x == ""
                 then pure $ MkDPair _ []
                 else do MkDPair _ xs <- readVect
                         pure $ MkDPair _ (x :: xs)

 -- since the dependent pair syntax is merely syntactic sugar for
 -- the DPair type
partial
readVect' : HasIO io => io (n : Nat ** Vect n String)
readVect' = do x <- getLine
               if x == ""
                  then pure $ (_ ** [])
                  else do (_ ** xs) <- readVect'
                          pure $ (_ ** (x :: xs))

printVect : HasIO io => (n : Nat ** Vect n String) -> io ()
printVect (n ** xs) = putStrLn $ show xs ++ " (length " ++ show n ++ ")"

printVect' : HasIO io => (n : Nat ** Vect n String) -> io ()
printVect' (MkDPair n xs) = putStrLn $ show xs ++ " (length " ++ show n ++ ")"


module Hangman

import Data.Vect
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]

validNil : ValidInput [] -> Void
validNil (Letter _) impossible

validNotSingle : ValidInput (x :: (y :: xs)) -> Void
validNotSingle (Letter _) impossible

isValidInput : (cs : List Char) -> Dec (ValidInput cs)
isValidInput [] = No $ validNil
isValidInput (x :: []) = Yes $ Letter x
isValidInput (x :: (y :: xs)) = No validNotSingle

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

readGuess : IO (g ** ValidInput g)
readGuess = do putStr "Enter a guess: "
               a <- getLine
               case isValidString a of
                    (Yes prf) => pure (_ ** prf)
                    (No contra) => putStrLn "Please enter a single character" >>= \_ => readGuess

processGuess : (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 $ removeElemAuto letter missing
                                                      No contra => Left $ MkWordState word missing

game : WordState (S guesses) (S letters) -> IO Finished
game {guesses} {letters} st = do (_ ** Letter c) <- readGuess
                                 case (processGuess c st) of
                                         (Left l) => do putStrLn "Your guess was wrong."
                                                        case guesses of
                                                            Z => pure $ Lost l
                                                            (S k) => game l
                                         (Right r) => do putStrLn "Correct!"
                                                         case letters of
                                                              Z => pure $ Won r
                                                              (S k) => game r

main : IO ()
main = let guessWord = "lambda"
           guessLetters = fromList (unpack guessWord)
           numGuesses = 3 in
        do gameres <- game {guesses=numGuesses-1} (MkWordState guessWord guessLetters)
           case gameres of
                (Lost game) => putStrLn $ "Thou hast lost. The word was: " ++ guessWord
                (Won game) => putStrLn "Congrats, you win!"


module Control.Comonad.Store.Representable

import Control.Comonad
import public Control.Comonad.Store.Interface
import Data.Functor.Representable

%default total

public export
data Store : (f : Type -> Type) -> {rep : Representable f r} -> Type -> Type where
  MkStore : {0 rep : Representable f r} -> f a -> r -> Store {rep} f a

public export
(rep : Representable f r) => Functor (Store f {rep}) where
  map f (MkStore s i) = MkStore (map f s) i

public export
(rep : Representable f r) => Comonad (Store f {rep}) where
  extract (MkStore s i) = s `index` i
  duplicate (MkStore s i) = MkStore (tabulate (MkStore s)) i

public export
(rep : Representable f r) => ComonadStore r (Store {rep} f) where
  pos (MkStore _ i) = i
  peek i (MkStore s _) = s `index` i

public export
store : (rep : Representable f r) => (r -> a) -> r -> Store {rep} f a
store g i = MkStore (tabulate g) i


module Numbers

import DataTypes
import Control.ST
import Control.ST.Exception
import Data.Complex
import Ratio
import Util
import Data.Fuel

%access public export

numToInt : LispVal -> ThrowsError LispVal
numToInt a@(LispInteger _) = pure a
numToInt (LispRational a) =
  if denominator a == 1
    then pure $ LispInteger (numerator a)
    else Left $ Default "Could not convert rational to integer"
numToInt (LispFloat a) =
  if a == cast (round a) -- TODO
    then pure $ LispInteger (round a)
    else Left $ Default "Could not convert float to integer"
numToInt (LispComplex a) =
  let rp = realPart a
  in if imagPart a == 0 && rp == cast (round rp)
       then pure $ LispInteger (round rp)
       else Left $ Default "Could not convert complex to integer"
numToInt _ = Left $ Default "Could not convert non-number to integer"

numCast : PrimitiveLispFunc
numCast [a@(LispInteger _), b@(LispInteger _)] = pure $ LispList [a, b]
numCast [a@(LispRational _), b@(LispRational _)] = pure $ LispList [a, b]
numCast [a@(LispFloat _), b@(LispFloat _)] = pure $ LispList [a, b]
numCast [a@(LispComplex _), b@(LispComplex _)] = pure $ LispList [a, b]
-- Integer
numCast [(LispInteger a), b@(LispRational _)] =
  pure $ LispList [LispRational (a .% 1), b]
numCast [(LispInteger a), b@(LispFloat _)] = pure $ LispList [LispFloat (fromInteger a), b]
numCast [(LispInteger a), b@(LispComplex _)] = pure $ LispList [LispComplex (fromInteger a :+ 0), b]
-- Rational
numCast [a@(LispRational _), (LispInteger b)] =
  pure $ LispList [a, LispRational (b .% 1)]
numCast [(LispRational a), b@(LispFloat _)] =
  case rationalCast a of
    Just flt => pure $ LispList [LispFloat flt, b]
    Nothing => Left $ Default "Unexpected error in numCast"
numCast [(LispRational a), b@(LispComplex _)] =
  case rationalCast a of
    Just flt => pure $ LispList [LispComplex (flt :+ 0), b]
    Nothing => Left $ Default "Unexpected error in numCast"
-- Float
numCast [a@(LispFloat _), (LispRational b)] =
  case rationalCast b of
    Just flt => pure $ LispList [a, LispFloat flt]
    Nothing => Left $ Default "Unexpected error in numCast"
numCast [a@(LispFloat _), (LispInteger b)] = pure $ LispList [a, LispFloat (fromInteger b)]
numCast [(LispFloat a), b@(LispComplex _)] = pure $ LispList [LispComplex (a :+ 0), b]
-- Complex
numCast [a@(LispComplex _), (LispRational b)] =
  case rationalCast b of
    Just flt => pure $ LispList [a, LispComplex (flt :+ 0)]
    Nothing => Left $ Default "Unexpected error in numCast"
numCast [a@(LispComplex _), (LispFloat b)] = pure $ LispList [a, LispComplex (b :+ 0)]
numCast [a@(LispComplex _), (LispInteger b)] = pure $ LispList [a, LispComplex (fromInteger b :+ 0)]
numCast [a, b] =
  case a of
    LispInteger _ => dothrow b
    LispFloat _ => dothrow b
    LispRational _ => dothrow b
    LispComplex _ => dothrow b
    _ => dothrow a
  where
    dothrow : LispVal -> ThrowsError LispVal
    dothrow num = Left $ TypeMismatch "Integer" num
numCast _ = Left $ Default "Unexpected error in numCast"

variadicNumberOp : LispVal -> (LispVal -> ThrowsError LispVal) -> PrimitiveLispFunc
variadicNumberOp ident op xs = helper xs ident
    where
        helper : List LispVal -> LispVal -> ThrowsError LispVal
        helper [] acc = pure acc
        helper (x::xs) acc =
            do c <- numCast [acc, x]
               d <- op c
               helper xs d

rationalBinaryOpHelper : (Rational -> Rational -> Maybe Rational) -> Rational -> Rational -> String -> ThrowsError LispVal
rationalBinaryOpHelper op a b opStr =
  case op a b of
    Just rat => pure $ LispRational rat
    Nothing => Left $ Default $ "Unexpected error in " ++ opStr

numAdd : PrimitiveLispFunc
numAdd = variadicNumberOp (LispInteger 0) doAdd
    where
        doAdd : LispVal -> ThrowsError LispVal
        doAdd (LispList [LispInteger c, LispInteger d]) = pure $ LispInteger (c + d)
        doAdd (LispList [LispRational c, LispRational d]) =
          rationalBinaryOpHelper rationalAdd c d "+"
        doAdd (LispList [LispFloat c, LispFloat d]) = pure $ LispFloat (c + d)
        doAdd (LispList [LispComplex c, LispComplex d]) = pure $ LispComplex (c + d)
        doAdd _ = Left $ Default "Unexpected error in +"

doSub : LispVal -> ThrowsError LispVal
doSub (LispList [LispInteger c, LispInteger d]) = pure $ LispInteger (c - d)
doSub (LispList [LispRational c, LispRational d]) =
  rationalBinaryOpHelper rationalSub c d "-"
doSub (LispList [LispFloat c, LispFloat d]) = pure $ LispFloat (c - d)
doSub (LispList [LispComplex c, LispComplex d]) = pure $ LispComplex (c - d)
doSub _ = Left $ Default "Unexpected error in -"

numSub : PrimitiveLispFunc
numSub [] = Left $ NumArgs (Min 1) 0 []
numSub [x] = variadicNumberOp (LispInteger 0) doSub [x]
numSub (x::xs) = variadicNumberOp x doSub xs

numMul : PrimitiveLispFunc
numMul [] = pure $ LispInteger 1
numMul xs = variadicNumberOp (LispInteger 1) doMul xs
  where
    doMul : LispVal -> ThrowsError LispVal
    doMul (LispList [LispInteger c, LispInteger d]) = pure $ LispInteger (c * d)
    doMul (LispList [LispRational c, LispRational d]) =
      rationalBinaryOpHelper rationalMul c d "*"
    doMul (LispList [LispFloat c, LispFloat d]) = pure $ LispFloat (c * d)
    doMul (LispList [LispComplex c, LispComplex d]) = pure $ LispComplex (c * d)
    doMul _ = Left $ Default "Unexpected error in *"

numDiv : PrimitiveLispFunc
numDiv [] = Left $ NumArgs (Min 1) 0 []
numDiv (x::xs) = variadicNumberOp x doDiv xs -- TODO: Zero division error
  where
    doDiv : LispVal -> ThrowsError LispVal
    doDiv (LispList [LispFloat c, LispFloat d]) =
      if d == 0.0
        then Left $ Default "Zero division error"
        else pure $ LispFloat (c / d)
    doDiv (LispList [LispComplex c, LispComplex d]) =
      if d == 0
        then Left $ Default "Zero division error"
        else pure $ LispComplex (c / d)
    doDiv (LispList [LispInteger c, LispInteger d]) =
      case (c :% d) of
        Just rat => pure $ LispRational rat
        Nothing => Left $ Default "Zero division error"
    doDiv (LispList [LispRational c, LispRational d]) =
      rationalBinaryOpHelper rationalDiv c d "/"
    doDiv _ = Left $ Default "Unexpected error in /"

numMod : PrimitiveLispFunc
numMod [a, b] =
    do
        c <- numCast $ [a, b]
        doMod c
    where
    modHelper : Integer -> Integer -> Integer
    modHelper n d =
      let k = cast (floor ((cast n) / (cast d)))
      in n - k * d
    doMod : LispVal -> ThrowsError LispVal
    doMod (LispList [LispInteger c, LispInteger d]) = pure $ LispInteger (modHelper c d)
    doMod (LispList [c@(LispRational _), d@(LispRational _)]) = do
      LispInteger c' <- numToInt c
      LispInteger d' <- numToInt d
      pure $ LispRational ((modHelper c' d') .% 1)
    doMod (LispList [c@(LispFloat _), d@(LispFloat _)]) = do
      LispInteger c' <- numToInt c
      LispInteger d' <- numToInt d
      pure $ LispFloat (fromInteger (modHelper c' d'))
    doMod (LispList [c@(LispComplex _), d@(LispComplex _)]) = do
      LispInteger c' <- numToInt c
      LispInteger d' <- numToInt d
      pure $ LispComplex (fromInteger (modHelper c' d') :+ 0)
    doMod _ = Left $ Default "Unexpected error in modulo"
numMod a = Left $ NumArgs (MinMax 2 2) (cast $ length a) a

numRem : PrimitiveLispFunc
numRem [a, b] =
    do
        c <- numCast $ [a, b]
        doRem c
    where
    doRem : LispVal -> ThrowsError LispVal
    doRem (LispList [LispInteger c, LispInteger d]) = pure $ LispInteger (c `mod` d) -- TODO `rem`?
    doRem (LispList [c@(LispRational _), d@(LispRational _)]) = do
      LispInteger c' <- numToInt c
      LispInteger d' <- numToInt d
      pure $ LispRational ((c' `mod` d') .% 1)
    doRem (LispList [c@(LispFloat _), d@(LispFloat _)]) =
        do
            LispInteger c' <- numToInt c
            LispInteger d' <- numToInt d
            pure $ LispFloat (fromInteger (c' `mod` d')) -- TODO `rem`?
    doRem (LispList [c@(LispComplex _), d@(LispComplex _)]) =
        do
            LispInteger c' <- numToInt c
            LispInteger d' <- numToInt d
            pure $ LispComplex (fromInteger (c' `mod` d') :+ 0) -- TODO `rem`?
    doRem _ = Left $ Default "Unexpected error in remainder"
numRem a = Left $ NumArgs (MinMax 2 2) (cast $ length a) a

isInteger : PrimitiveLispFunc
isInteger [LispInteger _] = pure $ LispBool True
isInteger [_] = pure $ LispBool False
isInteger a = Left $ NumArgs (MinMax 1 1) (cast $ length a) a

isRational : PrimitiveLispFunc
isRational [LispRational _] = pure $ LispBool True
isRational a = isInteger a

isReal : PrimitiveLispFunc
isReal [LispFloat _] = pure $ LispBool True
isReal a = isRational a

isComplex : PrimitiveLispFunc
isComplex [LispComplex _] = pure $ LispBool True
isComplex a = isReal a

isNumber : PrimitiveLispFunc
isNumber = isComplex

numBoolBinop :
     String
  -> (LispVal -> LispVal -> ThrowsError LispVal)
  -> LispVal
  -> List LispVal
  -> ThrowsError LispVal
numBoolBinop name' op b (c::d) = do
  LispList [b', c'] <- numCast [b, c]
  result <- op b' c'
  case result of
    LispBool True => numBoolBinop name' op c' d
    LispBool False => pure $ LispBool False
    _ => Left $ Default $ "Unexpected error in " ++ name'
numBoolBinop _ _ _ _ = pure $ LispBool True

numBoolBinopEq : PrimitiveLispFunc
numBoolBinopEq [] = Left $ NumArgs (Min 1) 0 []
numBoolBinopEq (x::xs) = numBoolBinop "=" fn x xs
  where
    fn : LispVal -> LispVal -> ThrowsError LispVal
    fn (LispInteger c) (LispInteger d) = pure $ LispBool (c == d)
    fn (LispRational c) (LispRational d) = pure $ LispBool (c == d)
    fn (LispFloat c) (LispFloat d) = pure $ LispBool (c == d)
    fn (LispComplex c) (LispComplex d) = pure $ LispBool (c == d)
    fn _ _ = Left $ Default "Unexpected error in ="

numBoolBinopNeq : PrimitiveLispFunc
numBoolBinopNeq [] = Left $ NumArgs (Min 1) 0 []
numBoolBinopNeq (x::xs) = numBoolBinop "/=" fn x xs
  where
    fn : LispVal -> LispVal -> ThrowsError LispVal
    fn (LispInteger c) (LispInteger d) = pure $ LispBool (c /= d)
    fn (LispRational c) (LispRational d) = pure $ LispBool (c /= d)
    fn (LispFloat c) (LispFloat d) = pure $ LispBool (c /= d)
    fn (LispComplex c) (LispComplex d) = pure $ LispBool (c /= d)
    fn _ _ = Left $ Default "Unexpected error in /="

numBoolBinopLt : PrimitiveLispFunc
numBoolBinopLt [] = Left $ NumArgs (Min 1) 0 []
numBoolBinopLt (x::xs) = numBoolBinop "<" fn x xs
  where
    fn : LispVal -> LispVal -> ThrowsError LispVal
    fn (LispInteger c) (LispInteger d) = pure $ LispBool (c < d)
    fn (LispRational c) (LispRational d) = pure $ LispBool (c < d)
    fn (LispFloat c) (LispFloat d) = pure $ LispBool (c < d)
    fn (LispComplex _) (LispComplex _) =
      Left $ Default "< not defined for complex numbers"
    fn _ _ = Left $ Default "Unexpected error in <"

numBoolBinopLte : PrimitiveLispFunc
numBoolBinopLte [] = Left $ NumArgs (Min 1) 0 []
numBoolBinopLte (x::xs) = numBoolBinop "<=" fn x xs
  where
    fn : LispVal -> LispVal -> ThrowsError LispVal
    fn (LispInteger c) (LispInteger d) = pure $ LispBool (c <= d)
    fn (LispRational c) (LispRational d) = pure $ LispBool (c <= d)
    fn (LispFloat c) (LispFloat d) = pure $ LispBool (c <= d)
    fn (LispComplex _) (LispComplex _) =
      Left $ Default "<= not defined for complex numbers"
    fn _ _ = Left $ Default "Unexpected error in <="

numBoolBinopGt : PrimitiveLispFunc
numBoolBinopGt [] = Left $ NumArgs (Min 1) 0 []
numBoolBinopGt
 (x::xs) = numBoolBinop ">" fn x xs
  where
    fn : LispVal -> LispVal -> ThrowsError LispVal
    fn (LispInteger c) (LispInteger d) = pure $ LispBool (c > d)
    fn (LispRational c) (LispRational d) = pure $ LispBool (c > d)
    fn (LispFloat c) (LispFloat d) = pure $ LispBool (c > d)
    fn (LispComplex _) (LispComplex _) =
      Left $ Default "> not defined for complex numbers"
    fn _ _ = Left $ Default "Unexpected error in >"

numBoolBinopGte : PrimitiveLispFunc
numBoolBinopGte [] = Left $ NumArgs (Min 1) 0 []
numBoolBinopGte (x::xs) = numBoolBinop ">=" fn x xs
  where
    fn : LispVal -> LispVal -> ThrowsError LispVal
    fn (LispInteger c) (LispInteger d) = pure $ LispBool (c >= d)
    fn (LispRational c) (LispRational d) = pure $ LispBool (c >= d)
    fn (LispFloat c) (LispFloat d) = pure $ LispBool (c >= d)
    fn (LispComplex _) (LispComplex _) =
      Left $ Default ">= not defined for complex numbers"
    fn _ _ = Left $ Default "Unexpected error in >="

numQuotient : PrimitiveLispFunc
numQuotient args =
  if length args /= 2
    then Left $ NumArgs (MinMax 2 2) (cast $ length args) args
    else do
      nums <- numCast args
      case nums of
        LispList [LispInteger a, LispInteger b] => pure $ LispInteger (a `div` b) -- TODO: Should be `quot`
        _ => Left $ Default "Unexpected error in <=" -- TODO better errors

unaryTrig : (Double -> Double) -> (Double -> Double -> Complex Double) -> PrimitiveLispFunc
unaryTrig op complexOp args =
  if length args /= 1
    then Left $ NumArgs (MinMax 1 1) (cast $ length args) args
    else case args of
           [LispInteger a] => pure $ LispFloat (op $ fromInteger a)
           [LispRational a] =>
              case rationalCast a of
                Just flt => pure $ LispFloat (op flt)
                Nothing => Left $ Default "Unexpected error" -- TODO: Better error
           [LispFloat a] => pure $ LispFloat (op a)
           [LispComplex a] => pure $ LispComplex $ complexOp (realPart a) (imagPart a)
           _ => Left $ Default "Numerical input expected"

numSine : PrimitiveLispFunc
numSine = unaryTrig sin (\r, i => ((sin r) * (cosh i)) :+ ((cos r) * (sinh i)))

numCos : PrimitiveLispFunc
numCos =
  unaryTrig cos (\r, i => ((cos r) * (cosh i)) :+ (-1 * ((sin r) * (sinh i))))

numToString : PrimitiveLispFunc
numToString [n] =
  do num <- isNumber [n]
     case num of
        LispBool True => pure $ LispString $ show n
        LispBool False => Left $ TypeMismatch "number?" n
        _ => Left $ Default "Unexpected error"

numPrimitives : List (String, PrimitiveLispFunc)
numPrimitives =
    [ ("+", numAdd)
    , ("-", numSub)
    , ("*", numMul)
    , ("/", numDiv)
    , ("modulo", numMod)
    , ("number?", isNumber)
    , ("complex?", isComplex)
    , ("real?", isReal)
    , ("rational?", isRational)
    , ("integer?", isInteger)
    , ("=", numBoolBinopEq)
    , ("/=", numBoolBinopNeq)
    , (">", numBoolBinopGt)
    , ("<", numBoolBinopLt)
    , (">=", numBoolBinopGte)
    , ("<=", numBoolBinopLte)
    , ("quotient", numQuotient)
    , ("remainder", numRem)
    , ("sin", numSine)
    , ("cos", numCos)
    , ("number->string", numToString)
    ]


module Data.Crypto.Encryption.TDEA

import Data.Vect

import Data.Crypto.Encryption.Block
import Data.Crypto.Encryption.Block.DEA
import Data.Fin

%default total
%access public export

TDEA1Key : Type
TDEA1Key = Vect 3 DEAKey

TDEA2Key : Type
TDEA2Key = Vect 2 DEAKey

data TripleDataEncryptionAlgorithm : Fin 2 -> Type where
  TDEA1 : TDEA1Key -> TripleDataEncryptionAlgorithm 0
  TDEA2 : TDEA2Key -> TripleDataEncryptionAlgorithm 1

implementation BlockCipher (TripleDataEncryptionAlgorithm 0) 64 (power 2 32) where
  encryptBlock (TDEA1 key) block =
    encryptBlock (DEA (index 2 key))
                 (decryptBlock (DEA (index 1 key))
                               (encryptBlock (DEA (index 0 key)) block))
  decryptBlock (TDEA1 key) block =
    decryptBlock (DEA (index 0 key))
                 (encryptBlock (DEA (index 1 key))
                               (decryptBlock (DEA (index 2 key)) block))

implementation BlockCipher (TripleDataEncryptionAlgorithm 1) 64 (power 2 20) where
  encryptBlock (TDEA2 key) = encryptBlock (TDEA1 (key ++ [index 0 key]))
  decryptBlock (TDEA2 key) = decryptBlock (TDEA1 (key ++ [index 0 key]))


import Aoc
import Data.List
import Data.Nat
import Data.Strings
import Data.SortedSet as S
%default total
-- TODO: this broke when I upgraded from 0.2.1 to 0.2.1-0a685f8d2... merry christmas

data Instruction
  = Nop Integer
  | Acc Integer
  | Jmp Integer

Program : Type
Program = List Instruction

parseInstruction : String -> Maybe Instruction
parseInstruction s =
  case words s of
    -- thankfully parseInteger has no problem with "+3"
    ["nop", n] => Nop <$> parseInteger n
    ["acc", n] => Acc <$> parseInteger n
    ["jmp", n] => Jmp <$> parseInteger n
    _ => Nothing

data Outcome = InfiniteLoop Integer | Terminated Integer
Show Outcome where
  show (InfiniteLoop acc) = "acc = " ++ show acc ++ " before infinite loop"
  show (Terminated acc) = "terminated with acc = " ++ show acc

-- This one's partial because... you know... (gestures)
partial
runFrom : (pc : Nat) -> (acc : Integer) -> (visited : SortedSet Nat) -> Program -> Outcome
runFrom pc acc visited program =
  if S.contains pc visited then InfiniteLoop acc else
    let visited' = S.insert pc visited in
    case maybeIndex pc program of
      Just (Nop _) => runFrom (pc+1) acc visited' program
      Just (Acc n) => runFrom (pc+1) (acc+n) visited' program
      Just (Jmp n) => runFrom (pc+integerToNat n) acc visited' program
      Nothing      => Terminated acc

partial
run : Program -> Outcome
run program = runFrom 0 0 S.empty program

||| Given an "edit" function that maybe applies to one element of the list,
||| try to apply it at every position in the list.
||| e.g.  halve n = if mod n 2 == 0 then Just (div n 2) else Nothing
|||       tryEach halve [10..13] = [[5,11,12,13], [10,11,6,13]]
tryEach : (a -> Maybe a) -> List a -> List (List a)
tryEach f xs = go f xs [] where
  go : (a -> Maybe a) -> List a -> List a -> List (List a)
  go f [] _ = []
  go f (x::xs) pre =
    case f x of
      Just y  => reverseOnto (y::xs) pre :: go f xs (x::pre)
      Nothing =>                            go f xs (x::pre)

||| Change nops into jmps and vice versa.
edit : Instruction -> Maybe Instruction
edit (Nop n) = Just $ Jmp n
edit (Jmp n) = Just $ Nop n
edit _ = Nothing

||| Extract Just a terminated accumulator from an outcome, else Nothing.
justTerminated : Outcome -> Maybe Integer
justTerminated (Terminated acc) = Just acc
justTerminated _ = Nothing

partial
main : IO ()
main = do
  program <- parseLines parseInstruction
  printLn $ length program
  putStr "*   "
  printLn $ run program
  putStr "**  "
  printLn $ mapMaybe (justTerminated . run) (tryEach edit program)


import Control.Monad.State

update : (stateType -> stateType) -> State stateType ()
update func =
  do
    currState <- get
    put (func currState)

increase : Nat -> State Nat ()
increase diff = update (+diff)


fib : HasIO io => Integer -> io Integer
fib 0 = pure 0
fib 1 = pure 1
fib n = pure $ !(fib (n - 1)) + !(fib (n - 2))

main : IO ()
main =  do
  value <- getLine
  printLn !(fib (cast value))


Toward $\pi$-calculus in idris
==============================

_WIP by [Dan Connolly][dckc], Apr 2018_

_This is a [literate idris][lp] document, with idris code ..._

> module picalc2
>
> %access export
> %default total

_... interspersed with text from ..._

* Milner, Robin. _[The polyadic π-calculus: a tutorial.][RM93]_
  In Logic and algebra of specification, pp. 203-246.
  Springer, Berlin, Heidelberg, 1993.

_We're having some fun with [KaTeX][] while we're at it._

[dckc]: http://www.madmode.com/contact/
[RM93]: https://pdfs.semanticscholar.org/5d25/0a3a14f68abb1ae0111d35b8220b4472b277.pdf
[lp]: http://docs.idris-lang.org/en/latest/tutorial/miscellany.html#literate-programming
[KaTeX]: https://khan.github.io/KaTeX/

2.1 Basic ideas
---------------

The most primitive entity in $\pi$-calculus is a _name_. Names,
infinitely many, are $x, y, ... \in \mathcal{X}$; they have no
structure. In the basic version of $\pi$-calculus which we begin
with, there is only one other kind of entity; a _process_.
Processes are $P, Q, ... \in \mathcal{P}$ and are built from names
by this syntax

  $$P ::= \Sigma_{i\in I}\pi_i.P_i \;|\; P|Q \;|\; !P \;|\; (\nu x)P$$

> {- `mutual` lets us forward reference Action from Process.-}
>
> syntax [p] "|" [q] = Par p q;
> syntax "!" [p] = (Replicated p);
>
> mutual
>   ||| Processes are built from names, so `Process` is a
>   ||| type constructor from names.
>   data Process : {name: Type} -> Type where

The summation form represents a process able to take part in one --
but only one -- of several alternatives for communication.

>     Sum: (List (Action {name}, Process {name})) -> Process {name}

$P | Q$ -- "$P$ par $Q$" -- simply means that $P$ and $Q$ are
concurrently active.

>     Par: (P: Process {name}) -> (Q: Process {name}) -> Process {name}

$!P$ -- "bang $P$" means $P|P|...$ as many copies as you wish.

>     Replicated: (P: Process {name}) -> Process {name}

$(\nu x)P$ -- "new $x$ in $P$" -- restricts the use of the name $x$ to $P$.

>     New: (x: name) -> (P: Process {name}) -> Process {name}

In a summand $\pi.P$ the prefix $\pi$ represents an _atomic action_,
the first action performed by $\pi.P$.

>   data Action : {name: Type} -> Type where

There are two basic forms of prefix:

 - $x(y)$, which binds $y$ in the prefix process, means
   "input some name -- call it $y$ -- along the link named $x$"

>     Input: (x: name) -> (y: name) -> Action {name}

 - $\bar{x}y$ , which does not bind $y$, means "output the name $y$
   along the link named $x$".

>     Output: (x: name) -> (y: name) -> Action {name}
>

In the case $I = \emptyset$, we write the sum as $0$.

> zero: Process
> zero = Sum []

We call $x$ the _subject_ ...

> subject: Action {name} -> name
> subject (Input x y) = x
> subject (Output x y) = x

We call ... $y$ the _object_

> object: Action {name} -> name
> object (Input x y) = y
> object (Output x y) = y

2.2 Some simple examples
------------------------

_typo?_

Note that $R$ has become $\bar{y}v$ or $\bar{z}v$; ...

_should be:_

Note that $Q$ has become $\bar{y}v$ or $\bar{z}v$; ...

_no?_

2.3 Structural Congruence
-------------------------

_Note: In order to convince idris of the [totality][] of `fn` and
`bn`, we use `assert_smaller` to help it understand that `(Sum rest)`
is structurally smaller than `(Sum ((pi, P) :: rest))`._

[totality]: http://docs.idris-lang.org/en/latest/reference/misc.html?highlight=assert_smaller#totality-checking-assertions

> mutual
>   ||| free names of a process
>   fn: Eq name => (Process {name}) -> (List name)
>   fn (Sum []) = []
>   fn (Sum ((pi, P) :: rest)) = union (fna pi) (union (fn P)
>    (fn (assert_smaller (Sum ((pi, P) :: rest)) (Sum rest))) )
>   fn (P | Q) = union (fn P) (fn Q)
>   fn (Replicated P) = fn P
>   fn (New x P) = delete x (fn P)
>
>   ||| free names of an action
>   fna: (Action {name}) -> (List name)
>   fna (Input x y) = [x]
>   fna (Output x y) = [x, y]
>
> mutual
>   ||| _names_ of a process
>   n: Eq name => Process {name} -> (List name)
>   n (Sum []) = []
>   n (Sum ((pi, P) :: rest)) = union (n' pi) (union (n P)
>          (n (assert_smaller (Sum ((pi, P) :: rest)) (Sum rest))) )
>     where
>     n': (Action {name}) -> (List name)
>     n' (Input x y) = [x, y]
>     n' (Output x y) = [x, y]
>   n (P | Q) = union (n P) (n Q)
>   n (Replicated P) = n P
>   n (New x P) = union [x] (n P)
>
>   ||| bound names of a process
>   bn: Eq name => (Process {name}) -> (List name)
>   bn P = (n P) \\ (fn P)

_Yay... idris can now compute:_

```
λΠ> bn (Sum [((Output "x" "y"), zero)])
[] : List String
λΠ> fn (Sum [((Output "x" "y"), zero)])
["x", "y"] : List String
```

_next step(s): use techniques from
[rhocaml](https://github.com/leithaus/rhocaml) to define
structural equivalence and then prove the laws._

<style type="text/css">
.sourceCode { background: azure }
</style>


import Control.ST
import Js.Dom
import Data.Vect

data TodoAction : Nat -> Type where
  TodoAdd : TodoAction n
  TodoChangeInputString : String -> TodoAction n
  TodoRemove : Fin n -> TodoAction n

record TodoState (n : Nat) where
  constructor MkTodoState
  todos : Vect n String
  inputString : String

removeTodo : Fin (S n) -> TodoState (S n) -> TodoState n
removeTodo i (MkTodoState tds inps) = MkTodoState (deleteAt i tds) inps

addTodo : TodoState n -> TodoState (S n)
addTodo (MkTodoState tds inps) = MkTodoState (inps :: tds) ""

Gui : Dom m => Nat -> Type
Gui {m} = DomRef {m} Nat TodoState TodoAction

vwTasks : Vect n String -> Html (TodoAction n)
vwTasks todos =
  let idxTodos = zip range todos
  in div [] (map renderTodo $ toList idxTodos)
  where
    renderTodo : (Fin n, String) -> Html (TodoAction n)
    renderTodo (idx, s) =
      div [] [button [onclick (TodoRemove idx)] "x", text s]

vw : (n:Nat) -> TodoState n -> Html (TodoAction n)
vw n st =
  div
    []
    [ form [] TodoAdd [input [onchange TodoChangeInputString, value $ inputString st]]
    , vwTasks $ todos st
    ]

total
lenAfterAction : (n : Nat) -> TodoAction n -> Nat
lenAfterAction n TodoAdd = S n
lenAfterAction (S n) (TodoRemove _) = n
lenAfterAction n (TodoChangeInputString _) = n

procAct : Dom m => (d:Var) -> (a:TodoAction n) -> ST m () [d ::: Gui {m} n :-> Gui {m} (lenAfterAction n a)]
procAct {n} d TodoAdd =
  domUpdateM d n (S n) addTodo
procAct {n=S k} d (TodoRemove i) =
  domUpdateM d (S k) k (removeTodo i)
procAct d (TodoChangeInputString s) =
  domUpdate d (record {inputString = s})

pageLoop : Dom m => (d:Var) -> ST m () [remove d (Gui {m} n)]
pageLoop d =
  do
    x <- getInput d
    procAct d x
    pageLoop d

page : Dom m => ST m () []
page =
  do
    d <- initBody [] vw 0 (MkTodoState [] "")
    pageLoop d

main : JS_IO ()
main = setASync_ $ run page


module Unit

import Basic

%default total

public export
data Unit : Type where
  MkUnit : Unit

public export
UnitInduction : (p : Unit -> Type) -> p () -> (x : Unit) -> p x
UnitInduction _ prop () = prop

public export
UnitRecursion : (p : Type) -> p -> Unit -> p
UnitRecursion _ p () = p

public export
UnitTerminal : (p : Type) -> p -> Unit
UnitTerminal _ = const ()


module ArithCmd

import System
import Arith

%default total

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

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

data Fuel = Empty | More (Lazy Fuel)

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

runCommand : Command a -> IO a
runCommand (PutStr x) = putStr x
runCommand GetLine = getLine

partial
forever : Fuel
forever = More forever

run : Fuel -> ConsoleIO a -> IO (Maybe a)
run Empty y = pure Nothing
run (More x) (Quit y) = pure $ Just y
run (More x) (Do z f) = do res <- runCommand z
                           run x $ f res
mutual
  correct : Stream Int -> (score : Nat) -> ConsoleIO Nat
  correct nums score
    = do PutStr "Correct!\n"
         quiz nums (score + 1)

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

  quiz : Stream Int -> (score : Nat) -> ConsoleIO Nat
  quiz (n1 :: n2 :: nums) score =
    do PutStr $ "Score so far: " ++ show score ++ "\n"
       PutStr $ show n1 ++ " * " ++ show n2 ++ "? "
       answer <- GetLine
       if toLower answer == "quit" then Quit score else
           if (cast answer == n1 * n2)
             then correct nums score
             else wrong nums (n1 * n2) score

partial
main : IO ()
main = do seed <- time
          Just score <- run forever (quiz (arithInputs (fromInteger seed)) 0)
               | Nothing => putStrLn "Ran out of fuel."
          putStrLn ("Final score: " ++ show score)


module Simple

x : Int
x = 2

y : Nat
y = 2 + ?a

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

Simple.a = proof
  intro n
  exact 2


module Bord

import System.Concurrency.Channels

import Data.Vect

%default total

infixl 9 -.-
infixl 3 ~>~

main: JS_IO ()
main = putStrLn' "hello"

namespace SigTy
  data SigTy: Type where
    Pos: Type -> SigTy
    Neg: Type -> SigTy
    (+): SigTy -> SigTy -> SigTy

  dual: SigTy -> SigTy
  dual (Pos x) = Neg x
  dual (Neg x) = Pos x
  dual (x + y) = dual x + dual y

data (~>~): SigTy -> SigTy -> Type where
  Pure:   (a -> b) -> Pos a ~>~ Pos b
  Io:     (a -> IO b) -> Pos a ~>~ Pos b
  (-.-):  (x ~>~ y) -> (y ~>~ z) -> (x ~>~ z)
  (+):    (w ~>~ x) -> (y ~>~ z) -> (w + y ~>~ x + z)
  Dual:   (x ~>~ y) -> (dual y ~>~ dual x)
  Unit:   (x: SigTy) -> (Pos Void ~>~ (dual x + x))
  CoUnit: (x: SigTy) -> (x + dual x ~>~ Pos Void)
  Join:   Pos a + Pos b    ~>~ Pos (Either a b)
  Split:  Pos (Either a b) ~>~ Pos a + Pos b
  Assoc:  (x,y,z: SigTy) -> x + (y + z) ~>~ (x + y) + z

plusEq: {x,x',y,y': SigTy} -> x = x' -> y = y' -> x + y = x' + y'
plusEq Refl Refl = Refl

dualIdem: (x: SigTy) -> dual (dual x) = x
dualIdem (Pos x) = Refl
dualIdem (Neg x) = Refl
dualIdem (x + y) = plusEq (dualIdem x) (dualIdem y)

lemma1: (x,y,z: SigTy) -> dual (dual x + dual y + dual z) = x + y + z
lemma1 x y z = plusEq (plusEq (dualIdem x) (dualIdem y)) (dualIdem z)

lemma2: (x,y,z: SigTy) -> dual (dual x + (dual y + dual z)) = x + (y + z)
lemma2 x y z = plusEq (dualIdem x) (plusEq (dualIdem y) (dualIdem z))

revAssoc: (x,y,z: SigTy) -> (x + y) + z ~>~ x + (y + z)
revAssoc x y z =    rewrite sym (lemma1 x y z)
                 in rewrite sym (lemma2 x y z)
                 in Dual (Assoc (dual x) (dual y) (dual z))

alpha: Pos Int ~>~ Pos Int
alpha = Pure id

beta: Pos String ~>~ Pos String
beta = Pure id

gamma: Neg String ~>~ Neg String
gamma = Dual (Pure id)

alphabeta: Pos Int + Pos String ~>~ Pos Int + Pos String
alphabeta = alpha + beta

middle: Pos Int + Pos String + Neg String ~>~ Pos Int + Pos String + Neg String
middle = alphabeta + gamma

right: Pos Int + Pos String + Neg String ~>~ Pos Int + Pos Void
right = revAssoc (Pos Int) (Pos String) (Neg String) -.- (Pure id + CoUnit (Pos String))

left: Pos Int + Pos Void ~>~ Pos Int + Pos String + Neg String
left = (Pure id + Unit (Neg String)) -.- Assoc (Pos Int) (Pos String) (Neg String)

big: Pos Int + Pos Void ~>~ Pos Int + Pos Void
big = left -.- middle -.- right

-- make processes

partial
inPortLoop: (a: Type) -> (f: a -> b) -> Channel -> Channel -> IO ()
inPortLoop a f sender_chan worker_chan = do
  Just i <- unsafeRecv a sender_chan
  ok <- unsafeSend worker_chan i
  inPortLoop a f sender_chan worker_chan

partial
inPort: (a: Type) -> (f: a -> b) -> IO ()
inPort a f = do
  Just sender_chan <- listen 1
  Just worker_chan <- listen 1
  inPortLoop a f sender_chan worker_chan

outPort: (b: Type) -> IO ()
outPort b = ?outPort_rhs

-- mkPure: (a -> b) -> IO (Maybe (Channel, Channel))
-- mkPure f = do
--   Just pure_id <- spawn pureProc
--     | Nothing => putStrLn "Error"


module Main

data ListZ : Type -> Type where
  (::) : a -> Lazy (ListZ a) -> ListZ a
  Nil  : ListZ a

implementation Show a => Show (ListZ a) where
  show xs = "[" ++ show' "" xs ++ "]"
      where
        show' acc Nil        = acc
        show' acc (x :: Nil) = acc ++ show x
        show' acc (x :: xs)  = show' (acc ++ show x ++ ", ") xs

foo : ListZ Nat
foo = (1 :: 2 :: 3 :: Nil)

main : IO ()
main = printLn foo


module Main

mutual
  %inline
  is_even : Int -> Int
  is_even n =
      if n == 0 then 1 else is_odd $ n-1

  is_odd : Int -> Int
  is_odd n =
      if n == 0 then 0 else is_even $ n-1

main : JS_IO ()
main = do
  putStr' $ show $ is_even 100001


||| Utilities for Language.Reflection.Refined
module Language.Reflection.Refined.Util

import public Data.Maybe
import public Data.So

%default total

--------------------------------------------------------------------------------
--          Utilities
--------------------------------------------------------------------------------

public export
maybeSo : (b : Bool) -> Maybe (So b)
maybeSo True  = Just Oh
maybeSo False = Nothing

public export
refineSo :  {f : a -> Bool}
         -> (make : (v : a) -> (0 prf : So $ f v) -> b)
         -> (val : a)
         -> Maybe b
refineSo make val = case maybeSo (f val) of
                         Just oh => Just $ make val oh
                         Nothing => Nothing