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  _∷_ _++_

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

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