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