-- | Some simple arithmetic exercises.
module Koans.Arithmetic

-- | There were 32 B/W Episodes of Ivor the Engine, and 72 episodes
-- were produced altogether. How many colour episodes were produced?
addition : Bool
addition = 40 + 32 == 72

-- | B/W Episodes of Ivor the Engine were ten minutes long. If you
-- were to watch all the episodes in one sitting how many minutes
-- would it take?
multiplication : Bool
multiplication = 320 == 10 * 32

-- | In what year did the Colourised version of Ivor the Engine first air?
subtraction : Bool
subtraction = 1977 + (-1974) == 3

-- | 26 B/W episodes of Ivor the Engine were discovered in a Pig shed
-- in 2010. There were two seasons. How many episodes per season were
-- there?
division : Bool
division = (26 `div` 13) == 2

-- | There were 32 B/W episodes of ten minutes each, and 40 colour
-- episodes of five minutes each. How many minutes of Ivor the Engine
-- exist?
parentheses : Int
parentheses = (32 * 10) + (40 * 5)

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


import Data.List

data MySnocList : List a -> Type where
     Empty : MySnocList []
     Snoc : (x, xs : _) -> (rec : MySnocList xs) -> MySnocList (xs ++ [x])

snocListHelp : {input : _} -> (snoc : MySnocList input) -> (rest : List a) -> MySnocList (input ++ rest)
snocListHelp snoc [] = rewrite appendNilRightNeutral input in snoc
snocListHelp snoc (x :: xs) = rewrite appendAssociative input [x] xs
                              in snocListHelp (Snoc x input snoc) xs

mySnocList : (xs : List a) -> MySnocList xs
mySnocList [] = Empty
mySnocList xs = snocListHelp Empty xs

myReverseHelper : (input : List a) -> MySnocList input -> List a
myReverseHelper [] Empty = []
myReverseHelper (xs ++ [x]) (Snoc x xs rec) = x :: myReverseHelper xs rec

-- myReverse : List a -> List a
-- myReverse input = myReverseHelper input (mySnocList input)

myReverse : List a -> List a
myReverse input with (mySnocList input)
  myReverse [] | Empty = []
  myReverse (xs ++ [x]) | (Snoc x xs rec) = x :: myReverse xs | rec

isSuffix : Eq a => List a -> List a -> Bool
isSuffix xs ys with (mySnocList xs, mySnocList ys)
  isSuffix _ _ | (Snoc x xs xsrec, Snoc y ys ysrec) = (x == y) && (isSuffix _ _ | (xsrec, ysrec))
  isSuffix _ _ | (Empty, s) = True
  isSuffix _ _ | (s, Empty) = False


import Data.List.Views

total
merge_sort : Ord a => List a -> List a
merge_sort xs with (splitRec xs)
  merge_sort [] | SplitRecNil = []
  merge_sort [x] | SplitRecOne = [x]
  merge_sort (lefts ++ rights) | (SplitRecPair lrec rrec)
    = merge (merge_sort lefts | lrec) (merge_sort rights | rrec)


module Linear.Math

import public Data.Floating
import public Data.Num

export
sigmoid : (Neg a, Floating a) => a -> a
sigmoid x = 1 / (1 + exp (-x))

export
relu : (Num a, Ord a) => a -> a
relu x = max 0 x


-- -------------------------------------------------------------- [ Ranges.idr ]
||| Module    : Ranges.idr
||| Copyright : (c) Jan de Muijnck-Hughes
||| License   : see LICENSE
|||
|||
module Commons.Data.Ranged

import Data.So

%access export
%default total

namespace Int

  data IntRange : (l,u : Int)
               -> (prf : So (l < u))
               -> Type where
    MkIntRange : (l,u : Int) -> (prf : So (l < u)) -> IntRange l u prf

  mkIntRange : (l,u : Int)
         -> {auto prf : So (l < u)}
         -> IntRange l u prf
  mkIntRange l u {prf} = MkIntRange l u prf

  data RangedInt : (lower : Int)
                -> (upper : Int)
                -> Type
    where
      MkRangedInt : (x     : Int)
                 -> (range : IntRange l u vrange)
                 -> (prf   : So (l <= x && x <= u))
                 -> RangedInt l u

  getValue : RangedInt l u -> Int
  getValue (MkRangedInt x _ _) = x

  getRange : RangedInt l u -> (Int, Int)
  getRange (MkRangedInt _ (MkIntRange l u _) _) = (l, u)

  inRange : (x : Int)
         -> (range : IntRange l u prf)
         -> Maybe (RangedInt l u)
  inRange x range with (choose $ l <= x && x <= u)
    inRange x range | (Left  okay) = Just $ MkRangedInt x range okay
    inRange x range | (Right nout) = Nothing

  Show (IntRange l u prf) where
    show (MkIntRange l u _) = unwords ["(", show l, ",", show u, ")"]

  Show (RangedInt l u) where
    show (MkRangedInt x (MkIntRange l u _) _) = unwords ["(", show l, "<=", show x, "<=", show u, ")"]

namespace Nat

  data NatRange : (l,u : Nat)
               -> (prf : LT l u)
               -> Type
    where
      MkNatRange : (l,u : Nat) -> (prf : LT l u) -> NatRange l u prf

  mkNatRange : (l,u : Nat) -> {auto prf : LT l u} -> NatRange l u prf
  mkNatRange l u {prf} = MkNatRange l u prf

  data RangedNat : (lower : Nat)
                -> (upper : Nat)
                -> Type where
    MkRangedNat : (x : Nat)
               -> (range : NatRange l u prfRange)
               -> (prfLower : LTE l x)
               -> (prfUpper : LTE x u)
               -> RangedNat l u

  getValue : RangedNat l u -> Nat
  getValue (MkRangedNat x _ _ _) = x

  getRange : RangedNat l u -> (Nat, Nat)
  getRange (MkRangedNat _ (MkNatRange l u _) _ _) = (l, u)

  inRange : (x : Nat)
         -> (range : NatRange l u prf)
         -> Maybe $ RangedNat l u
  inRange x (MkNatRange l u prf) with (isLTE l x)
    inRange x (MkNatRange l u prf) | (Yes y) with (isLTE x u)
      inRange x (MkNatRange l u prf) | (Yes y) | (Yes z) = Just (MkRangedNat x (MkNatRange l u prf) y z)
      inRange x (MkNatRange l u prf) | (Yes y) | (No contra) = Nothing
    inRange x (MkNatRange l u prf) | (No contra) = Nothing

  Show (NatRange l u prf) where
    show (MkNatRange l u prf) = unwords ["(", show l, ",", show u, ")"]

  Show (RangedNat l u) where
    show (MkRangedNat x (MkNatRange l u prf) _ _) = unwords ["(", show l, "<=", show x, "<=", show u, ")"]

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


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

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

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

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

treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))
treeLabelWith Empty = Pure Empty
treeLabelWith (Node left val right)
  = do left_labelled <- treeLabelWith left
       (this :: rest) <- get
       put rest
       right_labelled <- treeLabelWith right
       pure (Node left_labelled (this, val) right_labelled)

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

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


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

-- Checking that we can access 'n' from the index even though it's
-- not explicitly brought into scope, and the match requires n to be
-- Z or S k...
vlen : {n : Nat} -> Vect n a -> Nat
vlen [] = n
vlen (x :: xs) = n


import Data.DPair
import Data.List.Elem
import Data.List.Quantifiers

data IsEven : Nat -> Type where
  Z : IsEven Z
  S : IsEven k -> IsEven $ S $ S k

data IsPower2 : Nat -> Type where
  Base : IsPower2 1
  Next : IsPower2 k -> IsPower2 (k + k)

InterestingList : Type
InterestingList = List Nat `Subset` \xs => (All IsEven xs, (p1 ** p2 ** (Elem p1 xs, Elem p2 xs, IsPower2 p1, IsPower2 p2, Not $ p1 === p2)))

lxs : InterestingList
lxs = Element [2, 4] (%search, (2 ** 4 ** (%search, %search, Next Base, Next $ Next Base, \case Refl impossible)))


module Utils.Conjugate

import Data.Complex

%default total
%access public export

interface Conjugate space coSpace where
  conjug : space -> coSpace

implementation Neg a => Conjugate (Complex a) (Complex a) where
  conjug = conjugate

implementation Conjugate Double Double where
  conjug = id

implementation Conjugate Integer Integer where
  conjug = id

implementation Conjugate Nat Nat where
  conjug = id

implementation Conjugate Int Int where
  conjug = id


module Label

labelFrom : Integer -> List a -> List (Integer, a)
labelFrom n [] = []
labelFrom n (y :: ys) = (n, y) :: labelFrom (n+1) ys

label : List a -> List (Integer, a)
label = labelFrom 0


module Main

if' : (x : Bool) -> a -> b -> (if x then a else b)
if' True a b = a
if' False a b = b

theAnswer : Nat
theAnswer = 42

myFunc : (x : Bool) -> (if x then Nat else String)
myFunc input = if' input theAnswer "The Answer"

double : Nat -> Nat
double x = 2*x

main : IO ()
main = print (double $ myFunc True)
--This also works:
--main = print ("Hi" ++ myFunc False)
--Output: 84

--The following type errors:
--main = print ("Hi" ++ myFunc True)

{- This also type errors:
hasEven : List Nat -> Bool
hasEven [] = False
hasEven (x :: xs) = if mod x 2 == 0 then True else hasEven xs

main = print (double . myFunc $ hasEven [1,3,5,7,9,10])
-}


import Common

-- the `many` isomorphism: roughly List a <-> List b, constructed with
-- a retraction Maybe a < List b which satisfies a couple of simple
-- and necessary additional restrictions:
-- 1. (x:a) -> (all (isNothing . r) $ prefixes $ f (Just x) = True)
-- 2. (l:List b) -> isJust (r l) = True -> (f (r l)) = l

snoc : (x : a) -> List a -> List a
snoc x [] = [x]
snoc x (y :: xs) = (y :: snoc x xs)

reverse' : List a -> List a
reverse' [] = []
reverse' (x :: xs) = (snoc x (reverse' xs))

suffixes : List a -> List (List a)
suffixes [] = []
suffixes (x::xs) = xs :: suffixes xs

prefixes : List a -> List (List a)
prefixes = (map reverse') . suffixes . reverse'

all' : (a -> Bool) -> List a -> Bool
all' p [] = True
all' p (x::xs) = p x && all' p xs

data MRetraction : (a : Type) -> (b : Type) -> (f : Maybe a -> List b) -> (r : List b -> Maybe a) -> Type where
  MkMRetraction : (f : Maybe a -> List b) ->
                (r : List b -> Maybe a) ->
                (v : (x : Maybe a) -> r (f x) = x) ->
                (np: (x:a) -> (all' (isNothing . r) $ prefixes $ f (Just x) = True)) ->
                (ji: (l:List b) -> isJust (r l) = True -> (f (r l)) = l) ->
                (en: isNothing . r $ [] = True) ->
                MRetraction a b f r

data Many : Type -> Type -> Type where
  Nil : MRetraction a b f r ->
      (l: List b) ->
      (all' (isNothing . r) $ l :: prefixes l = True) ->
      Many a b
  Cons : MRetraction a b f r ->
       a ->
       Many a b ->
       Many a b

-- ^ this should be isomorphic to regular lists. informal proof:

-- Firstly, there is a retraction (Maybe a) < (List b), such that for
-- any l:List b = f x:a, there's no prefixes (counting Nil) of l that
-- could be read as other `a` values, and hence no ambiguity after
-- concatenation.

-- Secondly, input that can't be parsed goes into Many's Nil, and any
-- data that goes into Cons could be restored (another requirement on
-- the retraction), hence no data from List gets lost.

-- Obviously, no ambiguity in Maybe a -> List a translation, and no
-- data gets lost on translation into the list. Except for retraction
-- and proofs, maybe, so not that obviously, but they are kinda fixed.

manyExtractFirst' : (r : b -> Maybe a) -> (l: List b) -> all' (isNothing . r) l = False -> a
manyExtractFirst' r [] prf = void $ trueNotFalse prf
manyExtractFirst' r (x :: xs) prf with (r x)
  | Nothing = manyExtractFirst' r xs prf
  | Just x = x

manyExtractFirst : (r : List b -> Maybe a) ->
                 (l: List b) ->
                 (all' (isNothing . r) $ l :: prefixes l = False) ->
                 (isNothing . r $ [] = True) ->
                 a
manyExtractFirst r l p n = manyExtractFirst' r (l :: prefixes l) p

many : MRetraction a b f r ->
     Iso (Many a b) (List b)
many {a=a} {b=b} (MkMRetraction f r v np ji en) = MkIso to from tf ft
  where
  to : Many a b -> List b
  to (Nil r l s) = l
  to (Cons (MkMRetraction f _ _ _ _ _) x s) = f (Just x) ++ to s
  from : List b -> Many a b
  from l = case (inspect $ all' (isNothing . r) $ l :: prefixes l) of
    (match True {eq=eq}) => Nil (MkMRetraction f r v np ji en) l eq
    (match False {eq=eq}) =>
           Cons (MkMRetraction f r v np ji en)
                (manyExtractFirst r l eq en)
                (from (assert_smaller l (drop (length (f (Just (manyExtractFirst r l eq en)))) l)))
  tf x = ?manytf
  ft x = ?manyft

-- `Many` without a tail

data Many' : Type -> Type -> Type where
  Nil' : MRetraction a b f r ->
       Many' a b
  Cons' : MRetraction a b f r ->
        a ->
        Many' a b ->
        Many' a b

isNil : Many a b -> Bool
isNil (Nil _ _ _) = True
isNil (Cons _ _ _) = False

mto' : Many a b -> Many' a b
mto' (Nil r l s) = Nil' r
mto' (Cons r x m) = Cons' r x (mto' m)

mfrom' : Many' a b -> Many a b
mfrom' (Nil' (MkMRetraction f r v np ji en)) = Nil (MkMRetraction f r v np ji en) [] (rewrite en in Refl)
mfrom' (Cons' r x m) = Cons r x (mfrom' m)

mtail : Many a b -> List b
mtail (Cons _ _ m) = mtail m
mtail (Nil _ l _) = l

manyAnd : (mi: Iso (Many a b) (List b)) ->
        (cr: Retraction c (List b) cto cfrom) ->
        ((x:c) -> (isNil (unappIso mi (cto x)) = True)) ->
        ((l:List b) -> (isNil (unappIso mi l) = True) -> (cto (cfrom l) = l)) ->
        Iso (Many' a b, c) (List b)
manyAnd {a=a} {b=b} (MkIso mto mfrom mtf mft) (MkRetraction cto cfrom cft) p p2 = MkIso to from tf ft
  where
  to : (Many' a b, c) -> List b
  to (x, y) = mto (mfrom' x) ++ cto y
  from : List b -> (Many' a b, c)
  from l = case (mfrom l) of
    m => (mto' m, cfrom (mtail m))
  tf x = ?mvtf -- rewrite (ctf (mtail (mfrom x))) in ?mvtf
  ft x = ?mvft

-- examples

data Foo = Zero | One | End

bcto' : List Bool -> List Foo
bcto' [] = [End]
bcto' (False::xs) = Zero :: bcto' xs
bcto' (True::xs) = One :: bcto' xs

bcto : Maybe (List Bool) -> List Foo
bcto Nothing = []
bcto (Just l) = bcto' l

bcfrom : List Foo -> Maybe (List Bool)
bcfrom (Zero::xs) = do
  rest <- bcfrom xs
  Just (False :: rest)
bcfrom (One::xs) = do
  rest <- bcfrom xs
  Just (True :: rest)
bcfrom [End] = Just []
bcfrom _ = Nothing

boolFoo : MRetraction (List Bool) Foo bcto bcfrom
boolFoo = MkMRetraction bcto bcfrom v np ji en
  where
    v' : (l: List Bool) -> bcfrom (bcto' l) = Just l
    v' [] = Refl
    v' (False :: xs) = rewrite (v' xs) in Refl
    v' (True :: xs) = rewrite (v' xs) in Refl
    v : (l: Maybe (List Bool)) -> bcfrom (bcto l) = l
    v Nothing = Refl
    v (Just l) = v' l
    np x = believe_me ()
    ji l p = believe_me ()
    en = Refl

bsto : Bool -> Foo
bsto True = One
bsto False = Zero

bsfrom : Foo -> Bool
bsfrom End = False
bsfrom Zero = False
bsfrom One = True

boolFooS : Retraction (List Bool) (List Foo) (map bsto) (map bsfrom)
boolFooS = MkRetraction (map bsto) (map bsfrom) v
  where
  v [] = Refl
  v (False :: xs) = cong (v xs)
  v (True :: xs) = cong (v xs)

bfnbf : Iso (Many' (List Bool) Foo, List Bool) (List Foo)
bfnbf = manyAnd (many boolFoo) boolFooS p1 p2
  where
  -- ((x:List Bool) -> (isNil (unappIso (many boolFoo) (bsto x)) = True))
  -- there's never `End` in `bsto`, so it's `Nil`
  p1 = believe_me ()
  -- ((l:List b) -> (isNil (unappIso (many boolFoo) l) = True) -> (bsto (bsfrom l) = l))
  -- `Nil` happens only if there's no `End`, and in that case `bsto (bsfrom l) = l`
  p2 = believe_me ()

lfNil : Many (List Bool) Foo
lfNil = Nil boolFoo [] Refl

lfCons : List Bool -> Many (List Bool) Foo -> Many (List Bool) Foo
lfCons l m = Cons boolFoo l m

lfTest : Many (List Bool) Foo
lfTest =
       lfCons [True, False, True, True] $
              lfCons [True, True] $
                     lfCons [False, False] $
                            lfNil

-- λΠ> appIso (many boolFoo) lfTest
-- [One, Zero, One, One, End, One, One, End, Zero, Zero, End] : List Foo
-- λΠ> appIso (many boolFoo) $ unappIso (many boolFoo) [One, Zero, One, One, End, One, One, End, Zero, Zero]
-- [One, Zero, One, One, End, One, One, End, Zero, Zero] : List Foo
-- λΠ> appIso bfnbf ((mto' lfTest), [True, False])
-- [One, Zero, One, One, End, One, One, End, Zero, Zero, End, One, Zero] : List Foo


module Fix

%access public export

data Fix : (f : Type -> Type) -> Type where
    In : f (Fix f) -> Fix f

Show (f (Fix f)) => Show (Fix f) where
    show x = "In " ++ show x

inop : Fix f -> f (Fix f)
inop (In x) = x

cata : Functor f => (f a -> a) -> Fix f -> a
cata alg = alg . map (cata alg) . inop


module Data.List.Views

import Control.Relation
import Control.WellFounded
import Data.List
import Data.Nat
import Data.Nat.Views

%default total

lengthSuc : (xs : List a) -> (y : a) -> (ys : List a) ->
            length (xs ++ (y :: ys)) = S (length (xs ++ ys))
lengthSuc [] _ _ = Refl
lengthSuc (x :: xs) y ys = cong S (lengthSuc xs y ys)

lengthLT : (xs : List a) -> (ys : List a) ->
           LTE (length xs) (length (ys ++ xs))
lengthLT xs [] = reflexive {x = length xs}
lengthLT xs (x :: ys) = lteSuccRight (lengthLT _ _)

smallerLeft : (ys : List a) -> (y : a) -> (zs : List a) ->
              LTE (S (S (length ys))) (S (length (ys ++ (y :: zs))))
smallerLeft [] y zs = LTESucc (LTESucc LTEZero)
smallerLeft (z :: ys) y zs = LTESucc (smallerLeft ys _ _)

smallerRight : (ys : List a) -> (zs : List a) ->
               LTE (S (S (length zs))) (S (length (ys ++ (y :: zs))))
smallerRight ys zs = rewrite lengthSuc ys y zs in
                     (LTESucc (LTESucc (lengthLT _ _)))

||| View for splitting a list in half, non-recursively
public export
data Split : List a -> Type where
     SplitNil : Split []
     SplitOne : (x : a) -> Split [x]
     SplitPair : (x : a) -> (xs : List a) ->
                 (y : a) -> (ys : List a) ->
                 Split (x :: xs ++ y :: ys)

splitHelp : (head : a) ->
            (xs : List a) ->
            (counter : List a) -> Split (head :: xs)
splitHelp head [] counter = SplitOne _
splitHelp head (x :: xs) [] = SplitPair head [] x xs
splitHelp head (x :: xs) [y] = SplitPair head [] x xs
splitHelp head (x :: xs) (_ :: _ :: ys)
    = case splitHelp head xs ys of
           SplitOne x => SplitPair x [] _ []
           SplitPair x' xs y' ys => SplitPair x' (x :: xs) y' ys

||| Covering function for the `Split` view
||| Constructs the view in linear time
export
split : (xs : List a) -> Split xs
split [] = SplitNil
split (x :: xs) = splitHelp x xs xs

public export
data SplitRec : List a -> Type where
     SplitRecNil : SplitRec []
     SplitRecOne : (x : a) -> SplitRec [x]
     SplitRecPair : (lefts, rights : List a) -> -- Explicit, don't erase
                    (lrec : Lazy (SplitRec lefts)) ->
                    (rrec : Lazy (SplitRec rights)) -> SplitRec (lefts ++ rights)

||| Covering function for the `SplitRec` view
||| Constructs the view in O(n lg n)
public export
splitRec : (xs : List a) -> SplitRec xs
splitRec xs with (sizeAccessible xs)
  splitRec xs | acc with (split xs)
    splitRec []  | acc | SplitNil = SplitRecNil
    splitRec [x] | acc | SplitOne x = SplitRecOne x
    splitRec (y :: ys ++ z :: zs) | Access acc | SplitPair y ys z zs
      = SplitRecPair _ _
          (splitRec (y :: ys) | acc _ (smallerLeft ys z zs))
          (splitRec (z :: zs) | acc _ (smallerRight ys zs))

||| View for traversing a list backwards
public export
data SnocList : List a -> Type where
     Empty : SnocList []
     Snoc : (x : a) -> (xs : List a) ->
            (rec : SnocList xs) -> SnocList (xs ++ [x])

snocListHelp : {input : _} ->
               SnocList input -> (rest : List a) -> SnocList (input ++ rest)
snocListHelp snoc [] = rewrite appendNilRightNeutral input in snoc
snocListHelp snoc (x :: xs)
   = rewrite appendAssociative input [x] xs in
             snocListHelp (Snoc x input snoc) xs

||| Covering function for the `SnocList` view
||| Constructs the view in linear time
export
snocList : (xs : List a) -> SnocList xs
snocList xs = snocListHelp Empty xs


module ListExt3

%default total
%access public export

||| A "full" or non-empty list
FList : Type -> Type
FList a = (xs : List a ** NonEmpty xs)

infixr 5 :::

(:::) : a -> List a -> FList a
(:::) x xs = ((x :: xs) ** IsNonEmpty)

||| Proof that the first list is an improper prefix of the second list, with the
||| third list as the remainder.
data IsPrefixOf : FList a -> FList a -> List a -> Type where
  SingletonPrefix : IsPrefixOf (x ::: []) (x ::: rem) rem
  SuccPrefix : IsPrefixOf (xs ** _) (ys ** _) rem
             -> IsPrefixOf (x ::: xs) (x ::: ys) rem

interface PartialOrder (a : Type) (r : a -> a -> Type) where
  reflexive : (x : a) -> r x x
  antisymmetrical : (x : a) -> (y : a) -> r x y -> r y x -> x = y
  transitive : (x : a) -> (y : a) -> (z : a) -> r x y -> r y z -> r x z

prefixRefl : (xs : FList a) -> IsPrefixOf xs xs []
prefixRefl ((x :: []) ** IsNonEmpty) = SingletonPrefix
prefixRefl ((x :: (y :: xs)) ** IsNonEmpty) =
  -- TODO do whatever is needed to make Idris happy rather than assert_total
  SuccPrefix $ assert_total $ prefixRefl (y ::: xs)

prefixAntisym : (xs : FList a) -> (ys : FList a) -> (zs : List a)
              -> IsPrefixOf xs ys zs -> IsPrefixOf ys xs zs
              -> (xs = ys, zs = [])
prefixAntisym (xs ** xpf) (ys ** ypf) [] SingletonPrefix _ impossible
prefixAntisym (xs ** xpf) (ys ** ypf) [] (SuccPrefix _) _ impossible
prefixAntisym (xs ** xpf) (ys ** ypf) (_ :: _) SingletonPrefix _ impossible
prefixAntisym (xs ** xpf) (ys ** ypf) (_ :: _) (SuccPrefix _) _ impossible


module Data.Crypto.Util

import Data.Bits
import Data.Fin
import Data.Vect

import Data.Mod

%default total

trim : Bits (1 + n) -> Bits n
trim b = truncate (shiftRightLogical (intToBits 1) b)

public export
bitsToFin : Bits n -> Fin (power 2 n)
bitsToFin {n=Z}   _ = FZ
--bitsToFin {n=S _} b = let x = FS (FS FZ) * (bitsToFin (trim b))
--                      in if (b `and` (intToBits 1)) == (intToBits 0)
--                         then x
--                         else FS x
bitsToFin {n=S n} bits = fromMaybe (rewrite snd $ pow2NotZ n in FZ) (integerToFin (bitsToInt bits) (power 2 (S n)))
  where
  pow2NotZ : (n: Nat) -> (k ** power 2 n = S k)
  pow2NotZ  Z    = (Z**Refl)
  pow2NotZ (S n) = let (k**prf) = pow2NotZ n in
                   rewrite prf in
                   (k+(S (k+0))**Refl)

partial
divCeil : Nat -> Nat -> Nat
divCeil x y = case x `mod` y of
                Z   => x `div` y
                S _ => S (x `div` y)

public export
natToFi : (i : Nat) -> LTE i n -> Fin (S n)
natToFi  Z     LTEZero    = FZ
natToFi (S k) (LTESucc p) = FS (natToFi k p)

public export
finToBits : Fin n -> Bits (nextPow2 n)
finToBits = intToBits . finToInteger

public export
modToBits : Mod n -> Bits (nextPow2 n)
modToBits = intToBits . modToInteger

public export
rotateLeft : Nat -> Bits n -> Bits n
rotateLeft {n=n} rot bits =
  let norm = modNatNZ rot (S n) (uninhabited . sym)
  in shiftLeft bits (intToBits (cast norm)) `or` shiftRightLogical bits (intToBits (cast ((S n) `minus` norm)))

-- FIXME: This is rotateLeft currently. Need to change the impl
public export
rotateRight : Nat -> Bits n -> Bits n
rotateRight {n=n} rot bits =
  let norm = modNatNZ rot (S n) (uninhabited . sym)
  in shiftLeft bits (intToBits (cast norm)) `or` shiftRightLogical bits (intToBits (cast ((S n) `minus` norm)))

public export
swap : Fin n -> Fin n -> Vect n a -> Vect n a
swap i j v = replaceAt j (index i v) (replaceAt i (index j v) v)

public export
notZero : Nat -> Type
notZero Z = Void
notZero (S n) = ()

public export
tightmod : Nat -> (m : Nat) -> {default () ok : notZero m} -> Fin m
tightmod _ Z {ok=prf} = void prf
tightmod left (S modulus) = tightmod' left left modulus
  where
    tightmod' : Nat -> Nat -> (n : Nat) -> Fin (S n)
    tightmod' Z center right = fromMaybe FZ (natToFin center (S right))
    tightmod' (S left) center right =
      if lte center right
      then fromMaybe FZ (natToFin center (S right))
      else tightmod' left (center `minus` (S right)) right

public export
Byte : Type
Byte = Bits 8

public export
interface Serializable a where
  encode : a -> List (Bits n)
  decode : List (Bits n) -> a

-- Arrow defined for functions
infixr 3 ***
infixr 3 &&&
public export first : (a -> c) -> (a, b) -> (c, b)
first f = \(a, b) => (f a, b)
public export second : (b -> d) -> (a, b) -> (a, d)
second f = \(a, b) => (a, f b)
public export (***) : (a -> c) -> (b -> d) -> (a, b) -> (c, d)
f *** g = \(a, b) => (f a, g b)
public export (&&&) : (a -> c) -> (a -> d) -> a -> (c, d)
f &&& g = \a => (f a, g a)

postulate minusPlusIdentity : (m, n : Nat) -> (m `minus` n) + n = m
postulate plusMinusIdentity : (m, n : Nat) -> n + (m `minus` n) = m

public export
partition : Bits (m * n) -> Vect m (Bits n)
partition {m=Z}       _    = []
partition {m=S m} {n} bits =
  truncate (replace (plusCommutative n (m*n)) bits)
   :: partition (truncate (shiftRightLogical bits (intToBits (cast n))))

public export
partition' : Bits m -> (List (Bits n), (p : Nat ** Bits p))
partition' {m} {n} bits = part m bits
  where part : Nat -> Bits r -> (List (Bits n), (p : Nat ** Bits p))
        part      Z    bits = ([], (0 ** intToBits 0))
        part {r} (S q) bits =
          if r < n
          then ([], (r ** bits))
          else
            first (List.(::) (truncate (replace (sym (minusPlusIdentity r n)) (shiftRightLogical bits (intToBits (cast (r `minus` n)))))))
                  (part q (truncate (replace (sym (plusMinusIdentity r n)) bits)))

public export
append : Bits m -> Bits n -> Bits (m + n)
append {m} {n} a b = shiftLeft (zeroExtend a) (intToBits (cast n)) `or` (rewrite plusCommutative m n in zeroExtend b)

public export
concat : Vect m (Bits n) -> Bits (m * n)
concat {m=Z}       _         = intToBits 0
concat {m=S Z} {n} [bits]    = rewrite plusZeroRightNeutral n in bits
concat {m=S _}     (b::rest) = append b (concat rest)

public export
repartition : Vect m (Bits n) -> List (Bits q)
repartition = fst . partition' . Data.Crypto.Util.concat -- not at all efficient


module Control.Algebra

infixl 6 <->
infixl 7 <.>

public export
interface Semigroup ty => SemigroupV ty where
  semigroupOpIsAssociative : (l, c, r : ty) ->
    l <+> (c <+> r) = (l <+> c) <+> r

public export
interface (Monoid ty, SemigroupV ty) => MonoidV ty where
  monoidNeutralIsNeutralL : (l : ty) -> l <+> neutral {ty} = l
  monoidNeutralIsNeutralR : (r : ty) -> neutral {ty} <+> r = r

||| Sets equipped with a single binary operation that is associative,
||| along with a neutral element for that binary operation and
||| inverses for all elements. Satisfies the following laws:
|||
||| + Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Neutral for `<+>`:
|||     forall a,     a <+> neutral   == a
|||     forall a,     neutral <+> a   == a
||| + Inverse for `<+>`:
|||     forall a,     a <+> inverse a == neutral
|||     forall a,     inverse a <+> a == neutral
public export
interface MonoidV ty => Group ty where
  inverse : ty -> ty

  groupInverseIsInverseR : (r : ty) -> inverse r <+> r = neutral {ty}

(<->) : Group ty => ty -> ty -> ty
(<->) left right = left <+> (inverse right)

||| Sets equipped with a single binary operation that is associative
||| and commutative, along with a neutral element for that binary
||| operation and inverses for all elements. Satisfies the following
||| laws:
|||
||| + Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Commutativity of `<+>`:
|||     forall a b,   a <+> b         == b <+> a
||| + Neutral for `<+>`:
|||     forall a,     a <+> neutral   == a
|||     forall a,     neutral <+> a   == a
||| + Inverse for `<+>`:
|||     forall a,     a <+> inverse a == neutral
|||     forall a,     inverse a <+> a == neutral
public export
interface Group ty => AbelianGroup ty where
  groupOpIsCommutative : (l, r : ty) -> l <+> r = r <+> l

||| A homomorphism is a mapping that preserves group structure.
public export
interface (Group a, Group b) => GroupHomomorphism a b where
  to : a -> b

  toGroup : (x, y : a) ->
    to (x <+> y) = (to x) <+> (to y)

||| Sets equipped with two binary operations, one associative and
||| commutative supplied with a neutral element, and the other
||| associative, with distributivity laws relating the two operations.
||| Satisfies the following laws:
|||
||| + Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Commutativity of `<+>`:
|||     forall a b,   a <+> b         == b <+> a
||| + Neutral for `<+>`:
|||     forall a,     a <+> neutral   == a
|||     forall a,     neutral <+> a   == a
||| + Inverse for `<+>`:
|||     forall a,     a <+> inverse a == neutral
|||     forall a,     inverse a <+> a == neutral
||| + Associativity of `<.>`:
|||     forall a b c, a <.> (b <.> c) == (a <.> b) <.> c
||| + Distributivity of `<.>` and `<+>`:
|||     forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c)
|||     forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)
public export
interface Group ty => Ring ty where
  (<.>) : ty -> ty -> ty

  ringOpIsAssociative   : (l, c, r : ty) ->
    l <.> (c <.> r) = (l <.> c) <.> r
  ringOpIsDistributiveL : (l, c, r : ty) ->
    l <.> (c <+> r) = (l <.> c) <+> (l <.> r)
  ringOpIsDistributiveR : (l, c, r : ty) ->
    (l <+> c) <.> r = (l <.> r) <+> (c <.> r)

||| Sets equipped with two binary operations, one associative and
||| commutative supplied with a neutral element, and the other
||| associative supplied with a neutral element, with distributivity
||| laws relating the two operations. Satisfies the following laws:
|||
||| +  Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Commutativity of `<+>`:
|||     forall a b,   a <+> b         == b <+> a
||| + Neutral for `<+>`:
|||     forall a,     a <+> neutral   == a
|||     forall a,     neutral <+> a   == a
||| + Inverse for `<+>`:
|||     forall a,     a <+> inverse a == neutral
|||     forall a,     inverse a <+> a == neutral
||| + Associativity of `<.>`:
|||     forall a b c, a <.> (b <.> c) == (a <.> b) <.> c
||| + Neutral for `<.>`:
|||     forall a,     a <.> unity     == a
|||     forall a,     unity <.> a     == a
||| + Distributivity of `<.>` and `<+>`:
|||     forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c)
|||     forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)
public export
interface Ring ty => RingWithUnity ty where
  unity : ty

  unityIsRingIdL : (l : ty) -> l <.> unity = l
  unityIsRingIdR : (r : ty) -> unity <.> r = r

||| Sets equipped with two binary operations – both associative,
||| commutative and possessing a neutral element – and distributivity
||| laws relating the two operations. All elements except the additive
||| identity should have a multiplicative inverse. Should (but may
||| not) satisfy the following laws:
|||
||| + Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Commutativity of `<+>`:
|||     forall a b,   a <+> b         == b <+> a
||| + Neutral for `<+>`:
|||     forall a,     a <+> neutral   == a
|||     forall a,     neutral <+> a   == a
||| + Inverse for `<+>`:
|||     forall a,     a <+> inverse a == neutral
|||     forall a,     inverse a <+> a == neutral
||| + Associativity of `<.>`:
|||     forall a b c, a <.> (b <.> c) == (a <.> b) <.> c
||| + Unity for `<.>`:
|||     forall a,     a <.> unity     == a
|||     forall a,     unity <.> a     == a
||| + InverseM of `<.>`, except for neutral
|||     forall a /= neutral,  a <.> inverseM a == unity
|||     forall a /= neutral,  inverseM a <.> a == unity
||| + Distributivity of `<.>` and `<+>`:
|||     forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c)
|||     forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)
public export
interface RingWithUnity ty => Field ty where
  inverseM : (x : ty) -> Not (x = neutral {ty}) -> ty


data Expr num = Val num
              | Add (Expr num) (Expr num)
              | Sub (Expr num) (Expr num)
              | Mul (Expr num) (Expr num)
              | Div (Expr num) (Expr num)
              | Abs (Expr num)

Num ty => Num (Expr ty) where
    (+) = Add
    (*) = Mul
    fromInteger = Val . fromInteger

Neg ty => Neg (Expr ty) where
    negate x = 0 - x
    (-) = Sub

Abs ty => Abs (Expr ty) where
    abs = Abs

-- Exercise 7.3.1

Functor Expr where
    map func (Val x) = Val (func x)
    map func (Add x y) = Add (map func x) (map func y)
    map func (Sub x y) = Sub (map func x) (map func y)
    map func (Mul x y) = Mul (map func x) (map func y)
    map func (Div x y) = Div (map func x) (map func y)
    map func (Abs x) = Abs (map func x)

eval : (Abs num, Neg num, Integral num) => Expr num -> num
eval (Val x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)

Show num => Show (Expr num) where
     show (Val x) = show x
     show (Add x y) = show x ++ " + " ++ show y
     show (Sub x y) = show x ++ " - " ++ show y
     show (Mul x y) = show x ++ " * " ++ show y
     show (Div x y) = show x ++ " / " ++ show y
     show (Abs x) = "|" ++ show x ++ "|"

(Eq num, Num num, Abs num, Neg num, Integral num) => Eq (Expr num) where
     (==) x y = (eval x) == (eval y)

(Cast num toType, Abs num, Neg num, Integral num) => Cast (Expr num) toType where
     cast expr = cast (eval expr)


data Vect : Nat -> Type -> Type where
  Nil : Vect Z a
  (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a
%name Vect xs, ys, zs

append : Vect n elem -> Vect m elem -> Vect (n + m) elem
append [] ys = ys
append (x :: xs) ys = x :: append xs ys

data VectUnknown : Type -> Type where
  MkVect : (len : Nat) -> Vect len a -> VectUnknown a

read_vect : IO (VectUnknown String)
read_vect = do x <- getLine
               if (x == "")
                  then pure (MkVect _ [])
                  else do MkVect _ xs <- read_vect
                          pure (MkVect _ (x :: xs))

Show a => Show (Vect n a) where
  show [] = ""
  show (x :: xs) = show x ++ show xs

printVect : Show a => VectUnknown a -> IO ()
printVect (MkVect len xs) = let xss : String = show xs
                                lengths : String = show len in
                                putStrLn (xss ++ " (length " ++ lengths ++ ")")

Eq a => Eq (Vect n a) where
  (==) [] [] = True
  (==) (x :: xs) (y :: ys) = case x == y of
                                  True => xs == ys
                                  False => False


module elem

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

isElem : DecEq a => (x : a) -> (xs : List a) -> Maybe (Elem x xs)
isElem x [] = Nothing
isElem x (y :: xs) with (decEq x y)
  isElem x (x :: xs) | (Yes refl) = return Here
  isElem x (y :: xs) | (No f) = return (There !(isElem x xs))


module ListLast

public export
data ListLast : List a -> Type where
  Empty : ListLast []
  NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x])

export
total
listLast : (xs : List a) -> ListLast xs
listLast [] = Empty
listLast (x :: xs) = case listLast xs of
                          Empty => NonEmpty [] x
                          NonEmpty xs y => NonEmpty (x :: xs) y


module Ch04.Eval

import Ch03.Arith
import Ch04.NaturalInduction
import Data.Fin

%default total

mutual
  namespace IsBadBool
    ||| Propositional type describing that a term is a "bad boolean".
    data IsBadBool : Term -> Type where
      IsStuckTerm : {pf : IsStuck t} -> IsBadBool t
      IsNat : {pf : IsNumValue t} -> IsBadBool t

  namespace IsBadNat
    ||| Propositional type describing that a term is a "bad nat".
    data IsBadNat : Term -> Type where
      IsStuckTerm : {pf : IsStuck t} -> IsBadNat t
      IsBool : {pf : IsBoolValue t} -> IsBadNat t

  ||| Propositional type describing that a term is stuck.
  data IsStuck : Term -> Type where
    EIfWrong : {t1,t2,t3 : Term} ->
               {pf : IsBadBool t1} ->
               IsStuck (IfThenElse t1 t2 t3)
    ESuccWrong : {t : Term} ->
                 {pf : IsBadNat t} ->
                 IsStuck (Succ t)
    EPredWrong : {t : Term} ->
                 {pf : IsBadNat t} ->
                 IsStuck (Pred t)
    EIsZeroWrong : {t : Term} ->
                   {pf : IsBadNat t} ->
                   IsStuck (IsZero t)

-- We are using an ad hoc definition of what it means to be stuck,
-- which is not exactly the one used in the book (normal but not a value).
-- This is for convenience. (TODO: Fix this maybe.)
||| Propositional type describing that a term is fully evaluated.
FullyEvaluated : Term -> Type
FullyEvaluated t = Either (IsStuck t) (IsValue t)

||| Propositional type describing that a term is normal.
Normal : Term -> Type
Normal t = (t' : Term) -> EvalsTo t t' -> Void

--------------------------------------------------------------------------------
-- Helper lemmas for `fully_evaluated_is_normal`.
--------------------------------------------------------------------------------

true_is_normal : Normal True
true_is_normal = \_, r => case r of
                               EIfTrue impossible
                               EIfFalse impossible
                               (EIf _) impossible
                               (ESucc _) impossible
                               EPredZero impossible
                               EPredSucc impossible
                               (EPred _) impossible
                               EIsZeroZero impossible
                               EIsZeroSucc impossible
                               (EIsZero _) impossible

false_is_normal : Normal False
false_is_normal = \_, r => case r of
                                EIfTrue impossible
                                EIfFalse impossible
                                (EIf _) impossible
                                (ESucc _) impossible
                                EPredZero impossible
                                EPredSucc impossible
                                (EPred _) impossible
                                EIsZeroZero impossible
                                EIsZeroSucc impossible
                                (EIsZero _) impossible

zero_is_normal : Normal Zero
zero_is_normal = \_, r => case r of
                               EIfTrue impossible
                               EIfFalse impossible
                               (EIf _) impossible
                               (ESucc _) impossible
                               EPredZero impossible
                               EPredSucc impossible
                               (EPred _) impossible
                               EIsZeroZero impossible
                               EIsZeroSucc impossible
                               (EIsZero _) impossible

num_values_are_normal_helper : (nv : NumValue) -> Normal (nv2t nv)
num_values_are_normal_helper nv = case nv of
                                       Zero => zero_is_normal
                                       (Succ nv') => \_, r => case r of
                                                                    (ESucc r') => (num_values_are_normal_helper nv') _ r'

num_values_are_normal : (t : Term) -> {pf : IsNumValue t} -> Normal t
num_values_are_normal (nv2t nv) {pf=ConvertedFrom nv} = num_values_are_normal_helper nv

values_are_normal : (t : Term) -> {pf : IsValue t} -> Normal t
values_are_normal (bv2t bv) {pf=ConvertedFrom (Left bv)} = case bv of
                                                                True => true_is_normal
                                                                False => false_is_normal
values_are_normal (nv2t nv) {pf=ConvertedFrom (Right nv)} = num_values_are_normal (nv2t nv) {pf=ConvertedFrom nv}

num_value_not_bool_value : (nv : NumValue) -> Not (IsBoolValue (nv2t nv))
num_value_not_bool_value Zero = \pf_bv => case pf_bv of
                                               ConvertedFrom True impossible
                                               ConvertedFrom False impossible
num_value_not_bool_value (Succ nv) = \pf_bv => case pf_bv of
                                                    (ConvertedFrom True) impossible
                                                    (ConvertedFrom False) impossible

num_value_not_stuck : (nv : NumValue) -> Not (IsStuck (nv2t nv))
num_value_not_stuck Zero = \pf_bad => case pf_bad of
                                           EIfWrong impossible
                                           ESuccWrong impossible
                                           EPredWrong impossible
                                           EIsZeroWrong impossible
num_value_not_stuck (Succ nv) = \pf_bad => case pf_bad of
                                                ESuccWrong {pf=pf_succ_wrong} => case pf_succ_wrong of
                                                                                IsStuckTerm {pf=pf_stuck} => absurd ((num_value_not_stuck nv) pf_stuck)
                                                                                IsBool {pf=pf_bool} => absurd ((num_value_not_bool_value nv) pf_bool)

num_value_not_bad_nat : (nv : NumValue) -> Not (IsBadNat (nv2t nv))
num_value_not_bad_nat nv = \pf_bad => case pf_bad of
                                           IsStuckTerm {pf=pf_stuck} => absurd ((num_value_not_stuck nv) pf_stuck)
                                           IsBool {pf=pf_bool} => absurd ((num_value_not_bool_value nv) pf_bool)

values_not_stuck : {t : Term} -> {pf : IsValue t} -> Not (IsStuck t)
values_not_stuck {t = (bv2t bv)} {pf = (ConvertedFrom (Left bv))} = \pf_stuck => case bv of
                                                                                True => case pf_stuck of
                                                                                EIfWrong impossible
                                                                                ESuccWrong impossible
                                                                                EPredWrong impossible
                                                                                EIsZeroWrong impossible
                                                                                False => case pf_stuck of
                                                                                EIfWrong impossible
                                                                                ESuccWrong impossible
                                                                                EPredWrong impossible
                                                                                EIsZeroWrong impossible
values_not_stuck {t = (nv2t nv)} {pf = (ConvertedFrom (Right nv))} = num_value_not_stuck nv

bool_not_bad_bool : {t : Term} -> {pf : IsBoolValue t} -> Not (IsBadBool t)
bool_not_bad_bool {pf} = \x => case x of
                                    IsStuckTerm {pf=pf_stuck} => (values_not_stuck {pf=boolValueIsValue pf}) pf_stuck
                                    IsNat {pf=pf_nat} => numNotBool pf_nat pf

nat_not_bad_nat : {t : Term} -> {pf : IsNumValue t} -> Not (IsBadNat t)
nat_not_bad_nat {pf} = \x => case x of
                                  IsStuckTerm {pf=pf_stuck} => (values_not_stuck {pf=numValueIsValue pf}) pf_stuck
                                  IsBool {pf=pf_bool} => numNotBool pf pf_bool

stuck_is_normal : IsStuck t -> Normal t
stuck_is_normal (EIfWrong {pf}) = \_, r => case r of
                                                EIfTrue => (bool_not_bad_bool {pf=ConvertedFrom True}) pf
                                                EIfFalse => (bool_not_bad_bool {pf=ConvertedFrom False}) pf
                                                (EIf {t1} r') => case pf of
                                                                      IsStuckTerm {pf=pf_stuck} => stuck_is_normal pf_stuck _ r'
                                                                      IsNat {pf=pf_num} => values_are_normal t1 {pf=numValueIsValue pf_num} _ r'
stuck_is_normal (ESuccWrong {t} {pf}) = \_, r => case r of
                                                      (ESucc r') => case pf of
                                                                         IsStuckTerm {pf=pf_stuck} => stuck_is_normal pf_stuck _ r'
                                                                         IsBool {pf=pf_bool} => values_are_normal t {pf=boolValueIsValue pf_bool} _ r'
stuck_is_normal (EPredWrong {t} {pf}) = \_, r => case r of
                                                      EPredZero => nat_not_bad_nat {pf=ConvertedFrom Zero} pf
                                                      EPredSucc {nv1=nv} {pf=pf_num} => nat_not_bad_nat {pf=succNumValueIsNumValue pf_num} pf
                                                      (EPred r') => case pf of
                                                                         IsStuckTerm {pf=pf_stuck} => stuck_is_normal pf_stuck _ r'
                                                                         IsBool {pf=pf_bool} => values_are_normal t {pf=boolValueIsValue pf_bool} _ r'
stuck_is_normal (EIsZeroWrong {t} {pf}) = \_, r => case r of
                                                        EIsZeroZero => nat_not_bad_nat {pf=ConvertedFrom Zero} pf
                                                        EIsZeroSucc {nv1=nv} {pf=pf_num} => nat_not_bad_nat {pf=succNumValueIsNumValue pf_num} pf
                                                        (EIsZero r') => case pf of
                                                                             IsStuckTerm {pf=pf_stuck} => stuck_is_normal pf_stuck _ r'
                                                                             IsBool {pf=pf_bool} => values_are_normal t {pf=boolValueIsValue pf_bool} _ r'

||| Proof that a fully evaluated term is also normal.
fully_evaluated_is_normal : FullyEvaluated t -> Normal t
fully_evaluated_is_normal (Left pf_stuck) = stuck_is_normal pf_stuck
fully_evaluated_is_normal {t} (Right pf_value) = values_are_normal t {pf=pf_value}

-----------------------------------------------------------------------
-- Helper lemmas for `normal_is_fully_evaluated`.
-----------------------------------------------------------------------

if_subterm_of_normal_is_normal : {x,y,z : Term} -> Normal (IfThenElse x y z) -> Normal x
if_subterm_of_normal_is_normal pf = \_, r => absurd (pf _ (EIf r))

succ_subterm_of_normal_is_normal : {t : Term} -> Normal (Succ t) -> Normal t
succ_subterm_of_normal_is_normal pf = \_, r => absurd (pf _ (ESucc r))

pred_subterm_of_normal_is_normal : {t : Term} -> Normal (Pred t) -> Normal t
pred_subterm_of_normal_is_normal pf = \_, r => absurd (pf _ (EPred r))

is_zero_subterm_of_normal_is_normal : {t : Term} -> Normal (IsZero t) -> Normal t
is_zero_subterm_of_normal_is_normal pf = \_, r => absurd (pf _ (EIsZero r))

succ_of_fully_evaluated_is_fully_evaluated : {t : Term} -> FullyEvaluated t -> FullyEvaluated (Succ t)
succ_of_fully_evaluated_is_fully_evaluated {t} (Left pf_stuck) = Left (ESuccWrong {pf=IsStuckTerm {pf=pf_stuck}})
succ_of_fully_evaluated_is_fully_evaluated {t} (Right pf_val) = case pf_val of
                                                                     ConvertedFrom (Left bv) => Left (ESuccWrong {pf=IsBool {pf=ConvertedFrom bv}})
                                                                     ConvertedFrom (Right nv) => Right (numValueIsValue $ succNumValueIsNumValue (ConvertedFrom nv))

||| Proof that a normal term is also fully evaluated.
normal_is_fully_evaluated : Normal t -> FullyEvaluated t
normal_is_fully_evaluated {t=True} _ = Right (ConvertedFrom (Left True))
normal_is_fully_evaluated {t=False} _ = Right (ConvertedFrom (Left False))
normal_is_fully_evaluated {t=IfThenElse t1 t2 t3} pf_normal = case normal_is_fully_evaluated (if_subterm_of_normal_is_normal pf_normal) of
                                                                   (Left pf_stuck) => Left (EIfWrong {pf=IsStuckTerm {pf=pf_stuck}})
                                                                   (Right pf_val) => case pf_val of
                                                                                (ConvertedFrom (Left bv)) => case bv of
                                                                                True => absurd (pf_normal _ EIfTrue)
                                                                                False => absurd (pf_normal _ EIfFalse)
                                                                                (ConvertedFrom (Right nv)) => Left (EIfWrong {pf=IsNat {pf=ConvertedFrom nv}})
normal_is_fully_evaluated {t=Zero} _ = Right (ConvertedFrom (Right Zero))
normal_is_fully_evaluated {t=Succ t'} pf_normal = succ_of_fully_evaluated_is_fully_evaluated $
                                                  normal_is_fully_evaluated $
                                                  succ_subterm_of_normal_is_normal pf_normal
normal_is_fully_evaluated {t=Pred t'} pf_normal = case normal_is_fully_evaluated $ pred_subterm_of_normal_is_normal pf_normal of
                                                       Left pf_stuck => Left (EPredWrong {pf=IsStuckTerm {pf=pf_stuck}})
                                                       Right pf_val => case pf_val of
                                                                            (ConvertedFrom (Left bv)) => Left (EPredWrong {pf=IsBool {pf=ConvertedFrom bv}})
                                                                            (ConvertedFrom (Right Zero)) => absurd (pf_normal _ EPredZero)
                                                                            (ConvertedFrom (Right (Succ nv))) => absurd (pf_normal _ (EPredSucc {pf=ConvertedFrom nv}))
normal_is_fully_evaluated {t=IsZero t'} pf_normal = case normal_is_fully_evaluated $ is_zero_subterm_of_normal_is_normal pf_normal of
                                                         Left pf_stuck => Left (EIsZeroWrong {pf=IsStuckTerm {pf=pf_stuck}})
                                                         Right pf_val => case pf_val of
                                                                              (ConvertedFrom (Left bv)) => Left (EIsZeroWrong {pf=IsBool {pf=ConvertedFrom bv}})
                                                                              (ConvertedFrom (Right Zero)) => absurd (pf_normal _ EIsZeroZero)
                                                                              (ConvertedFrom (Right (Succ nv))) => absurd (pf_normal _ (EIsZeroSucc {pf=ConvertedFrom nv}))

--------------------------------------------------------------------------------
-- Definition of the evaluation function.
--------------------------------------------------------------------------------

eval_reduces_size_lemma1 : {n,m : Nat} ->
                           LTE (S n) (S ((n + m) + 1))
eval_reduces_size_lemma1 {n = Z} = LTESucc LTEZero
eval_reduces_size_lemma1 {n = (S k)} = LTESucc (eval_reduces_size_lemma1 {n=k})

eval_reduces_size_lemma2 : {n,m : Nat} ->
                           LTE (S m) (S ((n + m) + 1))
eval_reduces_size_lemma2 {n} {m} = rewrite plusCommutative n m in
                                           eval_reduces_size_lemma1

eval_reduces_size_lemma3 : {n,m,l : Nat} ->
                           LTE n m ->
                           LTE (l+n) (l+m)
eval_reduces_size_lemma3 {l = Z} pf = pf
eval_reduces_size_lemma3 {l = (S k)} pf = LTESucc (eval_reduces_size_lemma3 pf)

eval_reduces_size_lemma3' : {n,m,l : Nat} ->
                            LTE n m ->
                            LTE (n+l) (m+l)
eval_reduces_size_lemma3' {n} {m} {l} pf = rewrite plusCommutative n l in
                                                   rewrite plusCommutative m l in
                                                           eval_reduces_size_lemma3 pf

data ElementaryMonotoneFunction : (Nat -> Nat) -> Type where
  IsConstant : {c : Nat} -> ElementaryMonotoneFunction (const c)
  IsIdentity : ElementaryMonotoneFunction (\n => n) --TODO: Figure out why using `id {a=Nat}` fails to type check
  IsSum : {f,g : Nat -> Nat} ->
          ElementaryMonotoneFunction f ->
          ElementaryMonotoneFunction g ->
          ElementaryMonotoneFunction (\n => (f n) + (g n))

namespace ElementaryStrictlyMonotoneFunction
  data ElementaryStrictlyMonotoneFunction : (Nat -> Nat) -> Type where
    IsIdentity : ElementaryStrictlyMonotoneFunction (\n => n)
    IsSumLeft : {f,g : Nat -> Nat} ->
                ElementaryStrictlyMonotoneFunction f ->
                ElementaryMonotoneFunction g ->
                ElementaryStrictlyMonotoneFunction (\n => (f n) + (g n))
    IsSumRight : {f,g : Nat -> Nat} ->
                 ElementaryMonotoneFunction f ->
                 ElementaryStrictlyMonotoneFunction g ->
                 ElementaryStrictlyMonotoneFunction (\n => (f n) + (g n))

interface Monotone (P : (Nat -> Nat) -> Type) where
  monotone : (x, y : Nat) ->
             {f : Nat -> Nat} ->
             {pf : P f} ->
             LTE x y ->
             LTE (f x) (f y)

interface StrictlyMonotone (P : (Nat -> Nat) -> Type) where
  strictly_monotone : (x, y : Nat) ->
                      {f : Nat -> Nat} ->
                      {pf : P f} ->
                      LT x y ->
                      LT (f x) (f y)

Monotone ElementaryMonotoneFunction where
  monotone x y {f = (const c)} {pf = (IsConstant {c=c})} pf_assum = lteRefl
  monotone x y {f = (\n => n)} {pf = IsIdentity} pf_assum = pf_assum
  monotone x y {f = (\n => ((f n) + (g n)))} {pf = (IsSum {f} {g} pf_f pf_g)} pf_assum = let pf_assum_f = monotone x y {f=f} {pf=pf_f} pf_assum
                                                                                pf_assum_g = monotone x y {f=g} {pf=pf_g} pf_assum
                                                                                temp1 = eval_reduces_size_lemma3 {l=f x} pf_assum_g
                                                                                temp2 = eval_reduces_size_lemma3' {l=g y} pf_assum_f in
                                                                                lteTransitive temp1 temp2

StrictlyMonotone ElementaryStrictlyMonotoneFunction where
  strictly_monotone x y {f = (\n => n)} {pf = IsIdentity} pf_assum = pf_assum
  strictly_monotone x y {f = (\n => ((f n) + (g n)))} {pf = (IsSumLeft {f} {g} pf_f pf_g)} pf_assum = let pf_assum_f = strictly_monotone x y {f=f} {pf=pf_f} pf_assum
                                                                                pf_assum' = lteTransitive (lteSuccRight lteRefl) pf_assum
                                                                                pf_assum_g = monotone x y {f=g} {pf=pf_g} pf_assum'
                                                                                temp1 = eval_reduces_size_lemma3 {l=f y} pf_assum_g
                                                                                temp2 = eval_reduces_size_lemma3' {l=g x} pf_assum_f in
                                                                                lteTransitive temp2 temp1
  strictly_monotone x y {f = (\n => ((f n) + (g n)))} {pf = (IsSumRight {f} {g} pf_f pf_g)} pf_assum = let pf_assum_g = strictly_monotone x y {f=g} {pf=pf_g} pf_assum
                                                                                pf_assum' = lteTransitive (lteSuccRight lteRefl) pf_assum
                                                                                pf_assum_f = monotone x y {f=f} {pf=pf_f} pf_assum'
                                                                                temp1 = eval_reduces_size_lemma3 {l=f x} pf_assum_g
                                                                                temp2 = eval_reduces_size_lemma3' {l=g y} pf_assum_f in
                                                                                rewrite plusSuccRightSucc (f x) (g x) in
                                                                                lteTransitive temp1 temp2

-- Note: We need to define `if_then_else_size_f` explicitly using a lambda expression
-- (instead of pattern matching) because otherwise `pf_if_then_else_size_f` below will
-- fail to type check.
if_then_else_size_f : {n2, n3 : Nat} -> Nat -> Nat
if_then_else_size_f {n2} {n3} = \n => ((n + n2) + n3) + 1

pf_if_then_else_size_f : {n2, n3 : Nat} ->
                         ElementaryStrictlyMonotoneFunction (if_then_else_size_f {n2=n2} {n3=n3})
pf_if_then_else_size_f {n2} {n3} = IsSumLeft (IsSumLeft (IsSumLeft IsIdentity (IsConstant {c=n2})) (IsConstant {c=n3})) (IsConstant {c=1})

succ_size_f : Nat -> Nat
succ_size_f = \n => S n

pf_succ_size_f : ElementaryStrictlyMonotoneFunction Ch04.Eval.succ_size_f
pf_succ_size_f = IsSumRight (IsConstant {c=1}) IsIdentity

pred_size_f : Nat -> Nat
pred_size_f = \n => S n

pf_pred_size_f : ElementaryStrictlyMonotoneFunction Ch04.Eval.pred_size_f
pf_pred_size_f = IsSumRight (IsConstant {c=1}) IsIdentity

is_zero_size_f : Nat -> Nat
is_zero_size_f = \n => S n

pf_is_zero_size_f : ElementaryStrictlyMonotoneFunction Ch04.Eval.is_zero_size_f
pf_is_zero_size_f = IsSumRight (IsConstant {c=1}) IsIdentity

||| Proof that evaluation reduces size.
eval_reduces_size : {t,t' : Term} -> EvalsTo t t' -> LT (size t') (size t)
eval_reduces_size {t = (IfThenElse True t2 t3)} {t' = t2} EIfTrue = eval_reduces_size_lemma1
eval_reduces_size {t = (IfThenElse False t2 t3)} {t' = t3} EIfFalse = eval_reduces_size_lemma2
eval_reduces_size {t = (IfThenElse t1 t2 t3)} {t' = (IfThenElse t1' t2 t3)} (EIf x) = let pf = eval_reduces_size x in
                                                                                strictly_monotone (size t1') (size t1) {pf=pf_if_then_else_size_f} pf
eval_reduces_size {t = (Succ t1)} {t' = (Succ t2)} (ESucc x) = let pf = eval_reduces_size x in
                                                                   strictly_monotone (size t2) (size t1) {pf=pf_succ_size_f} pf
eval_reduces_size {t = (Pred Zero)} {t' = Zero} EPredZero = lteRefl
eval_reduces_size {t = (Pred (Succ t'))} {t' = t'} EPredSucc = LTESucc (lteSuccRight lteRefl)
eval_reduces_size {t = (Pred t1)} {t' = (Pred t2)} (EPred x) = let pf = eval_reduces_size x in
                                                                   strictly_monotone (size t2) (size t1) {pf=pf_pred_size_f} pf
eval_reduces_size {t = (IsZero Zero)} {t' = True} EIsZeroZero = lteRefl
eval_reduces_size {t = (IsZero (Succ nv1))} {t' = False} EIsZeroSucc = LTESucc (LTESucc LTEZero)
eval_reduces_size {t = (IsZero t1)} {t' = (IsZero t2)} (EIsZero x) = let pf = eval_reduces_size x in
                                                                         strictly_monotone (size t2) (size t1) {pf=pf_is_zero_size_f} pf

||| Proof that a term is either normal or evaluates to something. Note that this would be
||| a triviality if we were to assume the law of the excluded middle.
either_normal_or_evals : (t : Term) -> Either (Normal t) (t' : Term ** EvalsTo t t')
either_normal_or_evals True = Left true_is_normal
either_normal_or_evals False = Left false_is_normal
either_normal_or_evals (IfThenElse t1 t2 t3) = case either_normal_or_evals t1 of
                                                    Left pf_normal => case normal_is_fully_evaluated pf_normal of
                                                                           Left pf_stuck => Left (fully_evaluated_is_normal $
                                                                                Left (EIfWrong {pf=IsStuckTerm {pf=pf_stuck}}))
                                                                           Right pf_val => case pf_val of
                                                                                (ConvertedFrom (Left True)) => Right (t2 ** EIfTrue)
                                                                                (ConvertedFrom (Left False)) => Right (t3 ** EIfFalse)
                                                                                (ConvertedFrom (Right nv)) => Left (fully_evaluated_is_normal $
                                                                                Left (EIfWrong {pf=IsNat {pf=ConvertedFrom nv}}))
                                                    Right (t1' ** r) => Right ((IfThenElse t1' t2 t3) ** EIf r)
either_normal_or_evals Zero = Left zero_is_normal
either_normal_or_evals (Succ t) = case either_normal_or_evals t of
                                       Left pf_normal => Left (fully_evaluated_is_normal $
                                                        succ_of_fully_evaluated_is_fully_evaluated $
                                                        normal_is_fully_evaluated pf_normal)
                                       Right (t' ** r) => Right ((Succ t') ** (ESucc r))
either_normal_or_evals (Pred t) = case either_normal_or_evals t of
                                       Left pf_normal => case normal_is_fully_evaluated pf_normal of
                                                              Left pf_stuck => Left (fully_evaluated_is_normal $
                                                                              Left (EPredWrong {pf=IsStuckTerm {pf=pf_stuck}}))
                                                              Right pf_val => case pf_val of
                                                                                (ConvertedFrom (Left bv)) => Left (fully_evaluated_is_normal $
                                                                                Left (EPredWrong {pf=IsBool {pf=ConvertedFrom bv}}))
                                                                                (ConvertedFrom (Right Zero)) => Right (Zero ** EPredZero)
                                                                                (ConvertedFrom (Right (Succ nv))) => Right ((nv2t nv) ** EPredSucc {pf=ConvertedFrom nv})
                                       Right (t' ** r) => Right (_ ** (EPred r))
either_normal_or_evals (IsZero t) = case either_normal_or_evals t of
                                         Left pf_normal => case normal_is_fully_evaluated pf_normal of
                                                                Left pf_stuck => Left (fully_evaluated_is_normal $
                                                                                Left (EIsZeroWrong {pf=IsStuckTerm {pf=pf_stuck}}))
                                                                Right pf_val => case pf_val of
                                                                                (ConvertedFrom (Left bv)) => Left (fully_evaluated_is_normal $
                                                                                Left (EIsZeroWrong {pf=IsBool {pf=ConvertedFrom bv}}))
                                                                                (ConvertedFrom (Right Zero)) => Right (True ** EIsZeroZero)
                                                                                (ConvertedFrom (Right (Succ nv))) => Right (False ** EIsZeroSucc {pf=ConvertedFrom nv})
                                         Right (t' ** r) => Right (_ ** (EIsZero r))

||| Given a term, returns its value.
smallStep_eval : (t : Term) -> (v : Term ** (EvalsToStar t v, FullyEvaluated v))
smallStep_eval t = (inductive_construction size' f) (t ** Refl) where
  a : Type
  a = (t' : Term ** EvalsToStar t t')

  b : Type
  b = (t' : Term ** (EvalsToStar t t', FullyEvaluated t'))

  size' : a -> Nat
  size' (t' ** _) = size t'

  f : (x : a) -> Either b (x' : a ** LT (size' x') (size' x))
  f (t' ** p) = case either_normal_or_evals t' of
                     Left pf_normal => Left (t' ** (p, normal_is_fully_evaluated pf_normal))
                     Right (t'' ** p') => Right ((t'' ** (snoc p p')) ** eval_reduces_size p')


||| An approach to intrinsically-typed STLC with types as terms.
|||
||| We use this razor to demonstrate succintly how Type universes are
||| used to separate descriptions of how types are formed and their
||| use to type values.
|||
||| Standard constructions are used to represent the language as an
||| EDSL, together with proof of progress taken from PLFA Part 2.
|||
||| This module compliments Appendix 2 of the Functional Pearl.
|||
||| Although the code appears to be total, there is a known issues
||| with Idris2 totality checker that causes it to slow down when
||| dealing with mutually defined terms.
|||
module Razor.STLC

import Razor.Common

%default covering

namespace Types

  ||| Levels at which types and their types are defined in our type
  ||| universes.
  public export
  data Level = TYPE -- Build types here
             | VALUE -- Use types here.

  ||| Our types are meta types...
  public export
  data MTy : Level -> Type where

    BoolTyDesc : MTy TYPE
    BoolTy     : MTy VALUE

    FuncTy : MTy level -> MTy level -> MTy level

  ||| A predicate to type check types against type formers.
  public export
  data TyCheck : (type : MTy TYPE)
              -> (value : MTy VALUE)
              -> Type
    where
      ChkBool : TyCheck BoolTyDesc BoolTy

      ChkFunc : TyCheck paramTy  paramValue
             -> TyCheck returnTy returnValue
             -> TyCheck (FuncTy paramTy    returnTy)
                        (FuncTy paramValue returnValue)

  ||| A context is a list of types in different universes.
  public export
  Context : List Level -> Type
  Context = DList Level MTy

  public export
  Elem : Context lvls -> MTy level -> Type
  Elem g ty = Elem Level MTy ty g

namespace Terms

    public export
    data STLC : Context lvls -> MTy level -> Type where
      -- STLC

      Var : Elem Level MTy type ctxt -> STLC ctxt type

      Func : {paramTyType     : MTy TYPE}
          -> {paramTy, bodyTy : MTy VALUE}
          -> (type : STLC ctxt paramTyType)
          -> (term : STLC (ctxt +=         paramTy) bodyTy)
          -> (prf  : TyCheck paramTyType paramTy)
                  -> STLC  ctxt    (FuncTy paramTy  bodyTy)

      App : {paramTy, bodyTy : MTy VALUE}
         -> (func  : STLC ctxt (FuncTy paramTy bodyTy))
         -> (value : STLC ctxt         paramTy)
                  -> STLC ctxt                 bodyTy

      -- Type Constructors
      TyBool : STLC ctxt BoolTyDesc
      TyFunc : {paramMTy, returnMTy : MTy TYPE}
            -> (paramTy  : STLC ctxt paramMTy)
            -> (returnTy : STLC ctxt returnMTy)
                        -> STLC ctxt (FuncTy paramMTy returnMTy)

      -- Base Values
      True  : STLC ctxt BoolTy
      False : STLC ctxt BoolTy

namespace Renaming

  public export
  weaken : (func : Types.Elem old type
                -> Types.Elem new type)
        -> (Elem (old += type') type
         -> Types.Elem (new += type') type)

  weaken func Here = Here
  weaken func (There rest) = There (func rest)

  public export
  rename : (f : {level : Level}
             -> {type  : MTy level}
                      -> Types.Elem old type
                      -> Types.Elem new type)
        -> ({level : Level}
         -> {type : MTy level}
         -> STLC old type
         -> STLC new type)

  -- STLC
  rename f (Var idx) = Var (f idx)

  rename f (Func ty body prf)
    = Func (rename f ty) (rename (weaken f) body) prf

  rename f (App func param)
    = App (rename f func) (rename f param)

  -- Type Constructors
  rename f TyBool = TyBool
  rename f (TyFunc param body)
    = TyFunc (rename f param) (rename f body)

  -- Base Values
  rename f True  = True
  rename f False = False

namespace Substitution
  public export
  weakens : (f : {level : Level}
              -> {type  : MTy level}
                       -> Types.Elem old type
                       -> STLC new type)
         -> ({level : Level}
          -> {type  : MTy level}
                   -> Types.Elem (old += type') type
                   -> STLC (new += type') type)
  weakens f Here = Var Here
  weakens f (There rest) = rename There (f rest)

  -- general substitute
  namespace General
    public export
    subst : (f : {level : Level}
              -> {type  : MTy level}
                       -> Types.Elem old type
                       -> STLC new type)
         -> ({level : Level}
          -> {type  : MTy level}
                   -> STLC old type
                   -> STLC new type)

    -- STLC
    subst f (Var idx) = f idx

    subst f (Func type body prf)
      = Func (subst f type)
             (subst (weakens f) body)
             prf

    subst f (App func var)
      = App (subst f func) (subst f var)

    -- Types
    subst f TyBool = TyBool
    subst f (TyFunc param return)
      = TyFunc (subst f param) (subst f return)

    -- Base Values
    subst f True  = True
    subst f False = False

  namespace Single
    public export
    apply : {levelA : Level}
         -> {typeA  : MTy levelA}
         -> (this   : STLC ctxt typeB)
         -> (idx    : Elem (ctxt += typeB) typeA)
                   -> STLC ctxt typeA
    apply this Here = this
    apply this (There rest) = Var rest

    public export
    subst : {levelA,levelB : Level}
         -> {typeA         : MTy levelA}
         -> {typeB         : MTy levelB}
         -> (this          : STLC  ctxt           typeB)
         -> (inThis        : STLC (ctxt += typeB) typeA)
                          -> STLC  ctxt           typeA
    subst {ctxt} {typeA} {typeB} {levelA} {levelB} this inThis
      = General.subst (apply this) inThis

namespace Values

  public export
  data Value : STLC ctxt type -> Type where
    TrueV  : Value True
    FalseV : Value False
    FuncV : {body : STLC (ctxt += paramTy) bodyTy}
                 -> Value (Func type body prf)

    TyBoolV : Value TyBool
    TyFuncV : {param : STLC ctxt pty}
           -> {return : STLC ctxt rty}
           -> Value param
           -> Value return
           -> Value (TyFunc param return)

namespace Reduction

  public export
  data Redux : (this : STLC ctxt type)
            -> (that : STLC ctxt type)
            -> Type
    where
      -- Functions reduce
      SimplifyFuncAppFunc : (func : Redux this that)
                                 -> Redux (App this var)
                                          (App that var)

      SimplifyFuncAppVar : {this, that : STLC ctxt type}
                        -> {func       : STLC ctxt (FuncTy type return)}
                        -> (value      : Value func)
                        -> (var        : Redux this that)
                                      -> Redux (App func this)
                                               (App func that)

      ReduceFuncApp : (value : Value var)
                            -> Redux (App (Func type body prf) var)
                                     (subst var body)

      -- Simplify Function Types
      SimplifyTyFuncParam : (param : Redux this that)
                                  -> Redux (TyFunc this body)
                                           (TyFunc that body)

      SimplifyTyFuncBody : {this, that : STLC ctxt type}
                        -> {param      : STLC ctxt paramTy}
                        -> (value      : Value param)
                        -> (body       : Redux this that)
                                      -> Redux (TyFunc param this)
                                               (TyFunc param that)

namespace Progress
  public export
  data Progress : (term : STLC Nil type)
                       -> Type
    where
      Done : forall mty . {term : STLC Nil mty}
                        -> Value term
                        -> Progress term
      Step : {this, that : STLC Nil type}
          -> (prf        : Redux this that)
                        -> Progress this

  public export
  progress : (term : STLC Nil type)
          -> Progress term
  -- STLC
  progress {type} (Var _) impossible

  progress (Func type body prf) = Done FuncV

  progress (App func var) with (progress func)
    progress (App func var) | (Done prfF) with (progress var)
      progress (App (Func ty b prf) var) | (Done prfF) | (Done prfV)
        = Step (ReduceFuncApp prfV {body=b})
      progress (App func var) | (Done prfF) | (Step prfV)
        = Step (SimplifyFuncAppVar prfF prfV)
    progress (App func var) | (Step prfF)
      = Step (SimplifyFuncAppFunc prfF)

  -- Type Constructors
  progress TyBool = Done TyBoolV

  progress (TyFunc param return) with (progress param)
    progress (TyFunc param return) | (Done valueP) with (progress return)
      progress (TyFunc param return) | (Done valueP) | (Done valueR)
        = Done (TyFuncV valueP valueR)
      progress (TyFunc param return) | (Done valueP) | (Step prfR)
        = Step (SimplifyTyFuncBody valueP prfR)
    progress (TyFunc param return) | (Step prfP)
      = Step (SimplifyTyFuncParam prfP)

  -- Base Values
  progress True  = Done TrueV
  progress False = Done FalseV

namespace Evaluation

  public export
  data Reduces : (this : STLC ctxt type)
              -> (that : STLC ctxt type)
              -> Type
    where
      Refl  : {this : STLC ctxt type}
                   -> Reduces this this
      Trans : {this, that, end : STLC ctxt type}
           -> Redux this that
           -> Reduces that end
           -> Reduces this end

  public export
  data Finished : (term : STLC ctxt type)
                       -> Type
    where
      Normalised : {term : STLC ctxt type}
                        -> Value term
                        -> Finished term
      OOF : Finished term

  public export
  data Evaluate : (term : STLC Nil type) -> Type where
    RunEval : {this, that : STLC Nil type}
           -> (steps      : Inf (Reduces this that))
           -> (result     : Finished that)
                         -> Evaluate this

  public export
  data Fuel = Empty | More (Lazy Fuel)

  public export
  covering
  forever : Fuel
  forever = More forever

  public export
  compute : forall type
          . (fuel : Fuel)
         -> (term : STLC Nil type)
         -> Evaluate term
  compute Empty term = RunEval Refl OOF
  compute (More fuel) term with (progress term)
    compute (More fuel) term | (Done value) = RunEval Refl (Normalised value)
    compute (More fuel) term | (Step step {that}) with (compute fuel that)
      compute (More fuel) term | (Step step {that = that}) | (RunEval steps result)
        = RunEval (Trans step steps) result

public export
covering
run : forall type
    . (this : STLC Nil type)
           -> Maybe (Subset (STLC Nil type) (Reduces this))
run this with (compute forever this)
  run this | (RunEval steps (Normalised {term} x))
    = Just (Element term steps)
  run this | (RunEval steps OOF) = Nothing

namespace Example

  export
  example0 : STLC Nil BoolTy
  example0 = App (Func TyBool (Var Here) ChkBool) True

  export
  example1 : STLC Nil (FuncTy BoolTy BoolTy)
  example1 = (Func TyBool True ChkBool)

  export
  id : STLC Nil (FuncTy BoolTy BoolTy)
  id = (Func TyBool (Var Here) ChkBool)

  public export
  CBool : MTy VALUE
  CBool = FuncTy (FuncTy BoolTy BoolTy)
                 (FuncTy BoolTy BoolTy)

  public export
  TyCBool : STLC ctxt (FuncTy (FuncTy BoolTyDesc BoolTyDesc)
                              (FuncTy BoolTyDesc BoolTyDesc))
  TyCBool = TyFunc (TyFunc TyBool TyBool) (TyFunc TyBool TyBool)

  export
  zero : STLC ctxt CBool
  zero = Func (TyFunc TyBool TyBool)
              (Func TyBool
                    (Var Here)
                    ChkBool)
              (ChkFunc ChkBool ChkBool)

  export
  one : STLC ctxt CBool
  one = Func (TyFunc TyBool TyBool)
              (Func TyBool
                    (App (Var (There Here)) (Var Here))
                    ChkBool)
              (ChkFunc ChkBool ChkBool)

  export
  two : STLC ctxt CBool
  two = Func (TyFunc TyBool TyBool)
             (Func TyBool
                   (App (Var (There Here))
                        (App (Var (There Here)) (Var Here)))
                   ChkBool)
             (ChkFunc ChkBool ChkBool)

  export
  succ : STLC ctxt (FuncTy CBool CBool)
  succ = Func TyCBool
              (Func (TyFunc TyBool TyBool)
                    (Func TyBool
                          ((Var (There Here)) `App`
                               (((Var (There (There Here))) `App`
                                         (Var (There Here))) `App`
                                    (Var Here)))
                          ChkBool)
                    (ChkFunc ChkBool ChkBool))
              (ChkFunc (ChkFunc ChkBool ChkBool)
                       (ChkFunc ChkBool ChkBool))

  export
  plus : STLC Nil (CBool `FuncTy` (CBool `FuncTy` CBool))
  plus = Func TyCBool
              (Func TyCBool
                    (Func (TyFunc TyBool TyBool)
                          (Func TyBool
                                (App (App (Var (There (There (There Here))))
                                          (Var (There Here)))
                                     (App (App (Var (There (There Here))) (Var (There Here)))
                                          (Var Here)))
                                ChkBool
                          )
                          (ChkFunc ChkBool ChkBool)
                    )

                    (ChkFunc (ChkFunc ChkBool ChkBool)
                             (ChkFunc ChkBool ChkBool))
              )
              (ChkFunc (ChkFunc ChkBool ChkBool)
                       (ChkFunc ChkBool ChkBool))

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


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

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

Shape : Type
rotate : Shape -> Shape

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

turn_around : Shape -> Shape
turn_around = twice rotate


> module Basic.Operations

> %default total

> %access public export

* Extensions of |replace|, |cong|

> |||
> replace2 : {a : _} -> {a1 : _} -> {a2 : _} ->
>            {b : _} -> {b1 : _} -> {b2 : _} ->
>            {P : a -> b -> Type} ->
>            (a1 = a2) -> (b1 = b2) -> P a1 b1 -> P a2 b2
> replace2 Refl Refl p = p

> |||
> cong2 : {alpha : Type} ->
>         {beta : Type} ->
>         {gamma : Type} ->
>         {a1 : alpha} ->
>         {a2 : alpha} ->
>         {b1 : beta} ->
>         {b2 : beta} ->
>         {f : alpha -> beta -> gamma} ->
>         (a1 = a2) ->
>         (b1 = b2) ->
>         f a1 b1 = f a2 b2
> cong2 Refl Refl = Refl

> |||
> depCong1 : {alpha : Type} ->
>            {P : alpha -> Type} ->
>            {a1 : alpha} ->
>            {a2 : alpha} ->
>            {f : (a : alpha) -> P a} ->
>            (a1 = a2) ->
>            f a1 = f a2
> depCong1 Refl = Refl

> |||
> depCong2 : {alpha : Type} ->
>            {P : alpha -> Type} ->
>            {gamma : Type} ->
>            {a1 : alpha} ->
>            {a2 : alpha} ->
>            {Pa1 : P a1} ->
>            {Pa2 : P a2} ->
>            {f : (a : alpha) -> P a -> gamma} ->
>            (a1 = a2) ->
>            (Pa1 = Pa2) ->
>            f a1 Pa1 = f a2 Pa2
> depCong2 Refl Refl = Refl

> |||
> depCong2' : {alpha : Type} ->
>             {P : alpha -> Type} ->
>             {Q : (a : alpha) -> P a -> Type} ->
>             {a1 : alpha} ->
>             {a2 : alpha} ->
>             {Pa1 : P a1} ->
>             {Pa2 : P a2} ->
>             {f : (a : alpha) -> (pa : P a) -> Q a pa} ->
>             (a1 = a2) ->
>             (Pa1 = Pa2) ->
>             f a1 Pa1 = f a2 Pa2
> depCong2' Refl Refl = Refl


import Data.List.Views

mergeSort : Ord a => List a -> List a
mergeSort input with (splitRec input)
  mergeSort [] | SplitRecNil = []
  mergeSort [x] | SplitRecOne = [x]
  mergeSort (lefts ++ rights) | (SplitRecPair lrec rrec) =
    merge (mergeSort lefts | lrec) (mergeSort rights | rrec)


module Expr

%default total

data Expr num = Val num
              | Add (Expr num) (Expr num)
              | Sub (Expr num) (Expr num)
              | Mul (Expr num) (Expr num)
              | Div (Expr num) (Expr num)
              | Abs (Expr num)

Num ty => Num (Expr ty) where
  (+) = Add
  (*) = Mul
  fromInteger = Val . fromInteger

Neg ty => Neg (Expr ty) where
  negate x = 0 - x
  (-) = Sub

Abs ty => Abs (Expr ty) where
  abs = Abs

eval : (Abs num, Neg num, Integral num) => Expr num -> num
eval (Val n) = n
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)

e1 : Expr Int
e1 = Add (Val 6) (Mul (Val 3) (Val 12))


module OptimiseUnitary

import Data.Vect
import Data.Nat
import Unitary

simplify : Unitary n -> Unitary n -> (Unitary n, Bool)
simplify IdGate _ = (IdGate, False)
simplify _ IdGate = (IdGate, False)
simplify (H j x) (H k y) =
  if j == k then (y,True)
  else let (g,b) = simplify (H j x) y in (H k g, b)
simplify (H j x) (P p k y) =
  if j == k then (P p k y, False)
  else let (g,b) = simplify (H j x) y in (P p k g, b)
simplify (H j x) (CNOT c t y) =
  if j == c || j == t then (CNOT c t y, False)
  else let (g,b) = simplify (H j x) y in (CNOT c t g, b)
simplify (P p j x) (H k y) =
  if j == k then (H k y, False)
  else let (g,b) = simplify (P p j x) y in (H k g, b)
simplify (P p j x) (P p1 k y) =
  if j == k then (P (p + p1) k y, True)
  else let (g,b) = simplify (P p j x) y in (P p1 k g, b)
simplify (P p j x) (CNOT c t y) =
  if j == c || j == t then (CNOT c t y, False)
  else let (g,b) = simplify (P p j x) y in (CNOT c t g, b)
simplify (CNOT c t x) (H j y) =
  if j == c || j == t then (H j y, False)
  else let (g,b) = simplify (CNOT c t x) y in (H j g, b)
simplify (CNOT c t x) (P p j y) =
  if j == c || j == t then (P p j y, False)
  else let (g,b) = simplify (CNOT c t x) y in (P p j g, b)
simplify (CNOT c t x) (CNOT c1 t1 y) =
  if c == c1 && t == t1 then (y, True)
  else if c == c1 || t == t1 || c == t1 || t == c1
          then (CNOT c1 t1 y, False)
       else let (g,b) = simplify (CNOT c t x) y in (CNOT c1 t1 g, b)

optimise' : Unitary n -> (Unitary n, Bool)
optimise' IdGate = (IdGate, False)
optimise' (H j x) =
  let (g, b) = simplify (H j x) x
      (g1, b1) = optimise' g
  in if b then (g1, True)
     else (H j g1, b1)
optimise' (P p j x) =
  let (g, b) = simplify (P p j x) x
      (g1, b1) = optimise' g
  in if b then (g1, True)
     else (P p j g1, b1)
optimise' (CNOT c t x) =
  let (g, b) = simplify (CNOT c t x) x
      (g1, b1) = optimise' g
  in if b then (g1, True)
     else (CNOT c t g1, b1)

export
optimise : Unitary n -> Unitary n
optimise g =
  let (g1, b1) = optimise' g
  in if b1 then optimise g1
           else g1


-- Idea taken from http://liamoc.net/posts/2015-09-10-girards-paradox.html

%default total

data Set : Type where
  MkSet : (x : Type) -> (x -> Set) -> Set

In : Set -> Set -> Type
In a (MkSet _ f) = (x ** a = f x)

D : Set
D = MkSet (s ** Not $ s `In` s) fst

xind : x `In` D -> Not $ x `In` x
xind ((_ ** f) ** Refl) = f

xinx : {x : _} -> Not (x `In` x) -> x `In` D
xinx f = ((_ ** f) ** Refl)

dnotind : Not $ D `In` D
dnotind dind = xind dind dind

falso : Void
falso = dnotind $ xinx dnotind


module adder

adderTy : Nat -> Type
adderTy Z = Nat
adderTy (S k) = Nat -> adderTy k

adder : (k : Nat) -> Nat -> adderTy k
adder Z     acc = acc
adder (S k) acc = \ x => adder k (x + acc)


module DatatypeGeneric

data Data : Type where
  Unit : Data
  Zero : Data
  Param : Data
  Rec : Data
  Sum : Data -> Data -> Data
  Prod : Data -> Data -> Data

interp : Data -> Type -> Type -> Type
interp Unit param rec = ()
interp Zero param rec = Void
interp Param param rec = param
interp Rec param rec = rec
interp (Sum x y) param rec = Either (interp x param rec) (interp y param rec)
interp (Prod x y) param rec = (interp x param rec, interp y param rec)

data Mu : (dataF : Data) -> (a : Type) -> Type where
  In : interp dataF a (Mu dataF a) -> Mu dataF a

bimap : (dataF : Data) -> (f : a -> b) -> (g : c -> d) -> interp dataF a c -> interp dataF b d
bimap Unit f g () = ()
bimap Param f g a = f a
bimap Rec f g c = g c
bimap (Sum x y) f g (Left l) = Left (bimap x f g l)
bimap (Sum x y) f g (Right r) = Right (bimap y f g r)
bimap (Prod x y) f g (a, b) = (bimap x f g a, bimap y f g b)

interface Representable (f : Type -> Type) where
  rep : Data
  fromRep : Mu rep a -> f a
  toRep : f a -> Mu rep a

Representable List where
  rep = Sum Unit (Prod Param Rec)

  fromRep (In (Left ())) = []
  fromRep (In (Right (a, b))) = a :: fromRep b

  toRep [] = In (Left ())
  toRep (x :: xs) = In (Right (x, toRep xs))

gmap : {dataF : Data} -> (a -> b) -> Mu dataF a -> Mu dataF b
gmap {dataF = dataF} f (In x) = In $ bimap dataF f (gmap f) x

gcata : {dataF : Data} -> (interp dataF a c -> c) -> Mu dataF a -> c
gcata {dataF = dataF} f (In x) = f $ bimap dataF id (gcata f) x

map' : Representable f => (a -> b) -> f a -> f b
map' f fa = fromRep $ gmap f (toRep fa)

test : List Int
test = map' (\x => x + 1) [1..10]


||| Additional data types related to ordering notions
module Data.Order

%default total

||| Trichotomous formalises the fact that three relations are mutually exclusive.
||| It is meant to be used with relations that complement each other so that the
||| `Trichotomous lt eq gt` relation is the total relation.
public export
data Trichotomous : (lt, eq, gt : a -> a -> Type) -> (a -> a -> Type) where
  MkLT : {0 lt, eq, gt : a -> a -> Type} ->
         lt v w       -> Not (eq v w) -> Not (gt v w) -> Trichotomous lt eq gt v w
  MkEQ : {0 lt, eq, gt : a -> a -> Type} ->
         Not (lt v w) -> eq v w       -> Not (gt v w) -> Trichotomous lt eq gt v w
  MkGT : {0 lt, eq, gt : a -> a -> Type} ->
         Not (lt v w) -> Not (eq v w) -> gt v w       -> Trichotomous lt eq gt v w


> module InfiniteHorizonSequentialDecisionProblems.DeterministicTheory

> import Data.Vect
> import Syntax.PreorderReasoning

> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Vect.Operations
> import Vect.Properties

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

* -----------------------------
* Sequential decision processes
* -----------------------------

> State  :  Type
> Ctrl   :  (x : State) -> Type
> next   :  (x : State) -> (y : Ctrl x) -> State

* ----------------------------
* Sequential decision problems
* ----------------------------

> Val              :  Type
> reward           :  (x : State) -> (y : Ctrl x) -> (x' : State) -> Val
> (<+>)            :  Val -> Val -> Val
> LTE              :  Val -> Val -> Type

* --------
* Policies
* --------

> Policy  :  Type
> Policy  =  (x : State) -> Ctrl x

* ---------------------
* The value of policies
* ---------------------

The value of making infinite many decision steps with a policy by
starting from a given state is given by a "value" function

> val : Policy -> State -> Val

that fulfils the specification

> valSpec  :  Type
> valSpec  =  (p : Policy) -> (x : State) ->
>             val p x = reward x (p x) (next x (p x)) <+> val p (next x (p x))

A naive attempt at implementing |val| directly "from its specification"

< val p x = reward x (p x) (next x (p x)) <+> val p (next x (p x))

yiels a possibly non total function. In contrast to SDPs with a finite
number of decision steps, we cannot rely on an induction principle for
decision problems over an infinite number of steps. Obviously, there are
cases in which |val| can be implemented. For instance, if all states
have the same successor. An important case is when |State| is finite. We
discuss this case below.

* ----------------------
* Optimality of policies
* ----------------------

> Opt    :  Policy -> Type
> Opt p  =  (p' : Policy) -> (x : State) -> val p' x `LTE` val p x

* ----------------
* Optimal policies
* ----------------

Let |LTE| be a preorder

> reflexiveLTE     :  (a : Val) -> a `LTE` a
> transitiveLTE    :  {a, b, c : Val} -> a `LTE` b -> b `LTE` c -> a `LTE` c

and let |<+>| be monotonous w.r.t. |LTE|

> monotonePlusLTE  :  {a, b, c, d : Val} -> a `LTE` b -> c `LTE` d -> (a <+> c) `LTE` (b <+> d)

We can compute the value of making a first decision step with a given
control and then infinitely many further steps with a given policy in
terms of the (yet to be implemented) |val| function:

> cval        :  (p : Policy) -> (x : State) -> Ctrl x -> Val
> cval p x y  =  reward x y (next x y) <+> val p (next x y)

Assume that, for an arbitrary policy |p| and for an arbitrary state |x|,
we can pick up a control that maximises |cval p x|:

> cvalmax         :  (p : Policy) -> (x : State) -> Val
> cvalargmax      :  (p : Policy) -> (x : State) -> Ctrl x

> cvalargmaxSpec  :  (p : Policy) -> (x : State) -> cvalmax p x = cval p x (cvalargmax p x)
> cvalmaxSpec     :  (p : Policy) -> (x : State) -> (y : Ctrl x) -> cval p x y `LTE` cvalmax p x

This is certainly the case if |Ctrl x| is non empty and finite for any
|x| but there are more interesting cases in which we can compute "best"
controls. In these cases, a policy

> opt : Policy

that fulfils Bellman's equation

> optSpec  :  Type
> optSpec  =  (x : State) -> opt x = cvalargmax opt x

is optimal

> optLemma : (vs : valSpec) -> (os : optSpec) -> Opt opt

As in the case of |val|, we cannot implement |optLemma| in general. But
it is useful to look at a (possibly non total) implementation:

> optLemma vs os p' x = s9 where
>   s1 : val p' (next x (p' x)) `LTE` val opt (next x (p' x))
>   s1 = assert_total (optLemma vs os p' (next x (p' x)))
>   s2 : cval p' x (p' x) `LTE` cval opt x (p' x)
>   s2 = monotonePlusLTE (reflexiveLTE (reward x (p' x) (next x (p' x)))) s1
>   s3 : cval opt x (p' x) `LTE` cvalmax opt x
>   s3 = cvalmaxSpec opt x (p' x)
>   s4 : cvalmax opt x = cval opt x (cvalargmax opt x)
>   s4 = cvalargmaxSpec opt x
>   s5 : cval opt x (cvalargmax opt x) = cval opt x (opt x)
>   s5 = replace {P = \ U => cval opt x U = cval opt x (opt x)} (os x) Refl
>   s6 : cval opt x (opt x) = val opt x
>   s6 = sym (vs opt x)
>   s7 : cval p' x (p' x) `LTE` cvalmax opt x
>   s7 = transitiveLTE s2 s3
>   s8 : val p' x `LTE` cvalmax opt x
>   s8 = replace {P = \ W => W `LTE` cvalmax opt x} (sym (vs p' x)) s7
>   s9 : val p' x `LTE` val opt x
>   s9 = replace {P = \ W => val p' x `LTE` W} (trans (trans s4 s5) s6) s8

* -------------------------
* The case of finite states
* -------------------------

If |State| is finite

> finiteState : Finite State

we can compute the number of values of type |State|

> cardState : Nat
> cardState = card finiteState

and collect them in a vector

> vectState : Vect cardState State
> vectState = toVect finiteState

This representation of |State| is guaranteed to be complete

> completeVectState : (x : State) -> Elem x vectState
> completeVectState = toVectComplete finiteState

and injective

> inj1VectState : Injective1 vectState
> inj1VectState = toVectInjective1 finiteState

> inj2VectState : Injective2 vectState
> inj2VectState = injectiveLemma vectState inj1VectState

by construction. We can also represent the value of a policy by a value
table

> vt : Policy -> Vect cardState Val

and implement |val| in terms of the values of the table

> val p x = index k (vt p) where
>   k : Fin cardState
>   k = lookup x vectState (completeVectState x)

In this case, the specification of |val| defines a linear system of
equations for the components of the value table. To derive these
equations, consider, first the representation of |next|

> nextR : (k : Fin cardState) -> (y : Ctrl (index k vectState)) -> Fin cardState
> nextR k y = lookup x' vectState (completeVectState x') where
>   x' : State
>   x' = next (index k vectState) y

|nextR| is a representations of |next| in the sense that

> nextLemma  : (k : Fin cardState) -> (y : Ctrl (index k vectState)) ->
>              index (nextR k y) vectState = next (index k vectState) y

A proof of |nextLemma| is straightforward, see Appendix below. It is
also useful to define a representation for the reward function

> rewardR : (k : Fin cardState) -> (y : Ctrl (index k vectState)) -> Val
> rewardR k y = reward x y (next x y) where
>   x : State
>   x = index k vectState

and for policies:

> pR : (p : Policy) -> (k : Fin cardState) -> Ctrl (index k vectState)
> pR p k = p (index k vectState)

With |nextR|, |rewardR| and |pR|, we can derive the system of equations for
the components of |vt| by rewriting |valSpec p| for each component of
|vectState|:

> equation : (vs : valSpec) -> (p : Policy) -> (k : Fin cardState) ->
>            index k (vt p)
>            =
>            rewardR k (pR p k) <+> index (nextR k (pR p k)) (vt p)

To derive |equation|, it is useful to prove three intermediate results:

> lemma1 : (p : Policy) -> (k : Fin cardState) -> index k (vt p) = val p (index k vectState)

> lemma2 : (p : Policy) -> (k : Fin cardState) ->
>          reward (index k vectState) (p (index k vectState)) (next (index k vectState) (p (index k vectState)))
>          =
>          rewardR k (pR p k)

> lemma3 : (p : Policy) -> (k : Fin cardState) ->
>          val p (next (index k vectState) (p (index k vectState)))
>          =
>          index (nextR k (pR p k)) (vt p)

The implementations are given in the Appendix. With these lemmas, the
implementation of |equation| is directly follows from the definition of
|valSpec|:

> equation vs p k = let x = index k vectState in
>                   ( index k (vt p) )
>                 ={ lemma1 p k }=
>                   ( val p x )
>                 ={ vs p x }=
>                   ( reward x (p x) (next x (p x)) <+> val p (next x (p x)) )
>                 ={ replace {P = \ W => reward x (p x) (next x (p x)) <+> val p (next x (p x)) = W <+> val p (next x (p x))} (lemma2 p k) Refl }=
>                   ( rewardR k (pR p k) <+> val p (next x (p x)) )
>                 ={ replace {P = \ W => rewardR k (pR p k) <+> val p (next x (p x)) = rewardR k (pR p k) <+> W} (lemma3 p k) Refl }=
>                   ( rewardR k (pR p k) <+> index (nextR k (pR p k)) (vt p) )
>                 QED

* --------
* Appendix
* --------

> nextLemma k y = ( index (nextR k y) vectState )
>               ={ Refl }=
>                 ( index (lookup (next (index k vectState) y) vectState (completeVectState (next (index k vectState) y))) vectState )
>               ={ indexLookupLemma (next (index k vectState) y) vectState (completeVectState (next (index k vectState) y)) }=
>                 ( next (index k vectState) y )
>               QED

> lemma1 p k = ( index k (vt p) )
>            ={ replace {P = \ W => index k (vt p) = index W (vt p)} (sym (lookupIndexLemma k vectState inj2VectState (toVectComplete finiteState (index k vectState)))) Refl }=
>              ( index (lookup (index k vectState) vectState (toVectComplete finiteState (index k vectState))) (vt p) )
>            ={ Refl }=
>              ( val p (index k vectState) )
>            QED

> lemma2 p k = Refl

> lemma3 p k = ( val p (next (index k vectState) (p (index k vectState))) )
>            ={ Refl }= -- def. pR
>              ( val p (next (index k vectState) (pR p k)) )
>            ={ Refl }= -- def. val
>              ( index (lookup (next (index k vectState) (pR p k)) vectState (completeVectState (next (index k vectState) (pR p k)))) (vt p) )
>            ={ Refl }= -- def. nextR
>              ( index (nextR k (pR p k)) (vt p) )
>            QED

> {-

> ---}


-- examples in "Type-Driven Development with Idris"
-- chapter 13, section 2, Stack part

import Data.Vect

-- check that all functions are total
%default total

data StackCmd : Type -> Nat -> Nat -> Type where
  Push : Integer -> StackCmd () height (S height)
  Pop : StackCmd Integer (S height) height
  Top : StackCmd Integer (S height) (S height)
  Pure : ty -> StackCmd ty s s
  (>>=) : StackCmd a s1 s2 ->
          (a -> StackCmd b s2 s3) ->
          StackCmd b s1 s3

runStack : (stk : Vect inHeight Integer) ->
           StackCmd ty inHeight outHeight ->
           (ty, Vect outHeight Integer)
runStack stk (Push x) = ((), x :: stk)
runStack (x :: xs) Pop = (x, xs)
runStack (x :: xs) Top = (x, x :: xs)
runStack stk (Pure x) = (x, stk)
runStack stk (x >>= f)
  = let (res, stk') = runStack stk x in
      runStack stk' (f res)

testAdd : StackCmd Integer 0 0
testAdd = do Push 10
             Push 20
             val1 <- Pop
             val2 <- Pop
             Pure (val1 + val2)

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