```
module Lecture3 where

{- Note: the denotational semantics we looked at in this lecture
are in the file from lecture 2.
-}

--- Adding numbers to our language ---

-- Terms and values --

data Term : Set where
false : Term
true  : Term
if_then_else_ : (a b c : Term) → Term
-- natural number terms
O      : Term
succ   : (a : Term) → Term
pred   : (a : Term) → Term
iszero : (a : Term) → Term

-- We now distinguish between boolean values and natural number values.

data NValue : Set where
O    : NValue
succ : (n : NValue) → NValue

data BValue : Set where
true : BValue
false : BValue

data Value : Set where
bv : BValue → Value
nv : NValue → Value

-- Lifting values to terms.

nvalue : NValue → Term
nvalue O        = O
nvalue (succ n) = succ (nvalue n)

bvalue : BValue → Term
bvalue true  = true
bvalue false = false

value : Value → Term
value (bv b) = bvalue b
value (nv n) = nvalue n

-- Single step reduction --

data _⟶_ : Term → Term → Set where
E-IfTrue  : ∀ {t₂ t₃} → if true  then t₂ else t₃ ⟶ t₂
E-IfFalse : ∀ {t₂ t₃} → if false then t₂ else t₃ ⟶ t₃
E-If : ∀ {t₁ t₁′ t₂ t₃} →
t₁ ⟶ t₁′ →
if t₁ then t₂ else t₃ ⟶ if t₁′ then t₂ else t₃
-- Congruences
E-Succ   : ∀ {t₁ t₁′} → t₁ ⟶ t₁′ → succ   t₁ ⟶ succ   t₁′
E-Pred   : ∀ {t₁ t₁′} → t₁ ⟶ t₁′ → pred   t₁ ⟶ pred   t₁′
E-IsZero : ∀ {t₁ t₁′} → t₁ ⟶ t₁′ → iszero t₁ ⟶ iszero t₁′
-- pred
E-PredZero   : pred O ⟶ O
E-PredSucc   : ∀ n → pred (succ (nvalue n)) ⟶ nvalue n
-- iszero
E-IsZeroSucc : ∀ n → iszero (succ (nvalue n)) ⟶ false
E-IsZeroZero : iszero O ⟶ true

-- A many-step reduction is just a list of single step reduction chained
-- together.
data _⟶*_ : Term → Term → Set where
[]  : ∀ {a} → a ⟶* a
_∷_ : ∀ {a b c} → a ⟶ b → b ⟶* c → a ⟶* c

infixr 40 _∷_ _++_

-- Transitivity of many-step reduction (a.k.a. list append).
_++_ : ∀ {a b c} → a ⟶* b → b ⟶* c → a ⟶* c
[]       ++ qs = qs
(p ∷ ps) ++ qs = p ∷ ps ++ qs

-- Lifting the congruence rules to many-step reductions

-- We can write a general lifting function for the new rules.
map* : ∀ {f : Term → Term} → (∀ {a b} → a ⟶  b → f a ⟶  f b) →
∀ {a b} → a ⟶* b → f a ⟶* f b
map* g []       = []
map* g (p ∷ ps) = g p ∷ map* g ps

-- Unfortunately it doesn't quite work for E-If. The type checker
-- can't figure out the function f, so we need to give it explicitly.
E-If* : ∀ {t₁ t₁′ t₂ t₃} →
t₁ ⟶* t₁′ →
if t₁ then t₂ else t₃ ⟶* if t₁′ then t₂ else t₃
E-If* {t₂ = t₂}{t₃} = map* {λ x → if x then t₂ else t₃} E-If

-- Normal forms --

-- The empty type, logical 'false'
data ⊥ : Set where

-- We can define the logical negation of P as P implies false.
-- Interpreted as a type ¬ P is the type of functions from P to
-- the empty type.
¬_ : Set → Set
¬ P = P → ⊥

-- False implies anything.
contradiction : {A : Set} → ⊥ → A

-- A normal form is a term that cannot be reduced. First we define
-- what it means that a term _can_ be reduced.
data Red (a : Term) : Set where
red : ∀ b → a ⟶ b → Red a

-- Now we can define what it means to be a normal form.
NF : Term → Set
NF a = ¬ Red a

data IsValue : Term → Set where
isVal : ∀ v → IsValue (value v)

-- Stuck terms are normal forms which are not values
data Stuck a : Set where
stuck : NF a → ¬ IsValue a → Stuck a

-- Bad terms are terms which get stuck when they're evaluated
data Bad a : Set where
bad : ∀ b → Stuck b → a ⟶* b → Bad a

-- We could define good terms as the terms which don't get stuck
-- (EvalN and EvalB below), but that doesn't tell us very much about
-- which terms these are. Instead we declare which terms we believe
-- are good, and then prove that these actually evaluate nicely.
mutual
data IsBool : Term → Set where
B-true  : IsBool true
B-false : IsBool false
B-iszero : ∀ {a} → IsNat a → IsBool (iszero a)
B-if : ∀ {a b c} → IsBool a → IsBool b → IsBool c →
IsBool (if a then b else c)

data IsNat : Term → Set where
N-O : IsNat O
N-succ : ∀ {a} → IsNat a → IsNat (succ a)
N-pred : ∀ {a} → IsNat a → IsNat (pred a)
N-if : ∀ {a b c} → IsBool a → IsNat b → IsNat c →
IsNat (if a then b else c)

-- The well-behaved terms, that don't get stuck when evaluating.

data EvalB a : Set where
evalB : ∀ b → a ⟶* bvalue b → EvalB a

data EvalN a : Set where
evalN : ∀ n → a ⟶* nvalue n → EvalN a

-- The proof that our notion of good terms is a subset of the well-behaved terms.
-- To see what's going on, it can be helpful to comment the proof and redo it
-- yourself.

mutual
lem-isBool : ∀ {a} → IsBool a → EvalB a
lem-isBool B-true       = evalB true []
lem-isBool B-false      = evalB false []
lem-isBool (B-iszero p) with lem-isNat p
lem-isBool (B-iszero p) | evalN O p′ =
evalB true (map* E-IsZero p′ ++ E-IsZeroZero ∷ [])
lem-isBool (B-iszero p) | evalN (succ n) p′ =
evalB false (map* E-IsZero p′ ++ E-IsZeroSucc n ∷ [])
lem-isBool (B-if p q r) with lem-isBool p | lem-isBool q | lem-isBool r
lem-isBool (B-if p q r) | evalB true  p′ | evalB b q′ | _         =
evalB b (E-If* p′ ++ E-IfTrue ∷ q′)
lem-isBool (B-if p q r) | evalB false p′ | _         | evalB b r′ =
evalB b (E-If* p′ ++ E-IfFalse ∷ r′)

lem-isNat : ∀ {a} → IsNat a → EvalN a
lem-isNat N-O          = evalN O []
lem-isNat (N-succ p)   with lem-isNat p
... | evalN n p′ = evalN (succ n) (map* E-Succ p′)
lem-isNat (N-pred p)   with lem-isNat p
... | evalN O        p′ = evalN O (map* E-Pred p′ ++ E-PredZero ∷ [])
... | evalN (succ n) p′ = evalN n (map* E-Pred p′ ++ E-PredSucc n ∷ [])
lem-isNat (N-if p q r) with lem-isBool p | lem-isNat q | lem-isNat r
... | evalB true  p′ | evalN n q′ | _         =
evalN n (E-If* p′ ++ E-IfTrue ∷ q′)
... | evalB false p′ | _         | evalN n r′ =
evalN n (E-If* p′ ++ E-IfFalse ∷ r′)
```