module Chapter3.IDesc.Examples.Expr where

open import Data.Empty
open import Data.Unit hiding (_≤?_ ; _≟_)
open import Data.Sum
open import Data.Product
open import Data.Bool hiding (_≟_ ; T)
open import Data.Nat hiding (fold ;  _≟_ ; _*_)
open import Data.Fin hiding (_+_ ; _<_ ; fold)
open import Data.Vec hiding (lookup ; _>>=_)

open import Relation.Nullary
open import Relation.Binary hiding (_⇒_)
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality

open import Chapter1.Logic

open import Chapter2.IDesc
open import Chapter2.IDesc.Tagged
open import Chapter2.IDesc.Fixpoint

open import Chapter2.IDesc.Examples.Expr

open import Chapter3.IDesc.InitialAlgebra
open import Chapter3.IDesc.FreeMonad
open import Chapter3.IDesc.FreeMonad.IMonad
open import Chapter3.IDesc.FreeMonad.Monad


evalStep :  toDesc ExprD ⟧func Val  Val
evalStep (zero , v , tt) = v
evalStep (suc zero , true , ift , iff , tt) = ift
evalStep (suc zero , false , ift , iff , tt) = iff
evalStep {`nat} (suc (suc zero) , m , n , tt) = m + n
evalStep {`nat} (suc (suc (suc ())) , _)
evalStep {`bool} (suc (suc zero) , m , n , tt) =  m ≤? n 
evalStep {`bool} (suc (suc (suc ())) , _)


eval : Expr  Val
eval e = fold (toDesc ExprD)  {ty}  evalStep {ty}) e


data Context : Set where
  [] : Context
  _∷_ : (Γ : Context)(ty : Ty)  Context

Env : Context  Set
Env [] = 
Env (Γ  ty) = Env Γ × Val ty

Var : Context  Ty  Set
Var [] ty = 
Var (Γ  S) T = Var Γ T  S  T -- Want: True (S ≟ T)

lookup : ∀{Γ T}  Env Γ  Var Γ T  Val T
lookup {[]} γ ()
lookup {Γ  ty} (γ , _) (inj₁ x) = lookup γ x
lookup {Γ  ty} (_ , t) (inj₂ refl) = t

Term : Context  Ty  Set
Term Γ = ExprD * (Var Γ)

Expr' : Ty  Set
Expr' = ExprD *  _  )

toExpr : Expr'  Expr
toExpr = fold ExprD'  {T}  help {T})
  where ExprD' : func Ty Ty
        ExprD' = toDesc (ExprD *D  _  ))
        help :  ExprD' ⟧func Expr  Expr
        help (zero , () , _)
        help (suc zero , v , tt) = val v
        help (suc (suc zero) , b , ift , iff , tt) = cond b ift iff
        help {`nat} (suc (suc (suc zero)) , m , n , tt) = plus m n
        help {`nat} (suc (suc (suc (suc ()))) , _)
        help {`bool} (suc (suc (suc zero)) , m , n , tt) = le m n
        help {`bool} (suc (suc (suc (suc ()))) , _)

discharge : ∀{Γ T}  Env Γ  Var Γ T  Expr' T
discharge γ v =  suc zero , lookup γ v , tt  

substExpr : ∀{Γ}  Env Γ  Term Γ  Expr' 
substExpr γ tm = tm >>= discharge γ
  where open RawIMonad (monad ExprD)

evalTerm : ∀{Γ T}  Env Γ  Term Γ T   Val T
evalTerm γ tm = eval (toExpr (substExpr γ tm))