-- IntroEffects/Eval.lean

import IntroEffects.SmallStep

def evalSingleStep : Computation → Option Computation
 
| .app (.lam body) v => some <| instantiateComp v body
 
| .app (.recfun body) v => some <| instantiate2 (.recfun body) v body
| .ite (.bool true) c₁ _ => some c₁
| .ite (.bool false) _ c₂ => some c₂
 
| .bind (.ret v) c => some <| instantiateComp v c
 
| .bind (.opCall op v body) c => some <| .opCall op v (.bind body c)
| .bind c₁ c₂ => (evalSingleStep c₁).map (fun c₁' => .bind c₁' c₂)
   
| .handle (.hdl h) (.ret v) => some <| instantiateComp v h.ret
| .handle (.hdl h) (.opCall op v body) =>
  match h.lookup op with
   
  | some ⟨_, c⟩ =>
    let cont := .lam (.handle (.hdl h) body)
    some <| instantiate2 v cont c
   
  | none => some <| .opCall op v (.handle (.hdl h) body)
| .handle (.hdl h) c =>
  (evalSingleStep c).map (fun c' => .handle (.hdl h) c')
| .join (.string s₁) (.string s₂) => some <| .ret (.string (strAppend s₁ s₂))
| .fst (.pair v₁ _) => some <| .ret v₁
| .snd (.pair _ v₂) => some <| .ret v₂
| .add (.num v₁) (.num v₂) => some <| .ret (.num (v₁ + v₂))
| .sub (.num v₁) (.num v₂) => some <| .ret (.num (v₁ - v₂))
| .max (.num v₁) (.num v₂) => some <| .ret (.num (Max.max v₁ v₂))
| .lt (.num v₁) (.num v₂) => some <| .ret (.bool (v₁ < v₂))
| .mul (.num v₁) (.num v₂) => some <| .ret (.num (v₁ * v₂))
| .eq v₁ v₂ => some <| .ret (.bool (v₁ == v₂))
| _ => none

def evalFuel : Nat → Computation → Option Computation
| 0, _ => none
| _+1, .ret v => some <| .ret v
| _+1, .opCall n v c => some <| .opCall n v c
| n+1, c =>
  match evalSingleStep c with
  | some c' => evalFuel n c'
  | none => none

-- Repository definitions used:
content: scoped syntax num : embedded

content: def instantiateComp (what : Value) (comp : Computation) : Computation :=
  instantiateComputationLvl what 0 comp

content: def instantiateComputationLvl (what : Value) (level : Nat) : Computation → Computation
| .ret v => .ret <| instantiateValueLvl what level v
| .opCall op v c => .opCall op (instantiateValueLvl what level v) (instantiateComputationLvl what (level+1) c)
| .bind c₁ c₂ => .bind (instantiateComputationLvl what level c₁) (instantiateComputationLvl what (level+1) c₂)
| .ite v c₁ c₂ => .ite (instantiateValueLvl what level v) (instantiateComputationLvl what level c₁) (instantiateComputationLvl what level c₂)
| .app v₁ v₂ => .app (instantiateValueLvl what level v₁) (instantiateValueLvl what level v₂)
| .handle v c => .handle (instantiateValueLvl what level v) (instantiateComputationLvl what level c)
| .join v₁ v₂ => .join (instantiateValueLvl what level v₁) (instantiateValueLvl what level v₂)
| .fst v => .fst (instantiateValueLvl what level v)
| .snd v => .snd (instantiateValueLvl what level v)
| .add v₁ v₂ => .add (instantiateValueLvl what level v₁) (instantiateValueLvl what level v₂)
| .sub v₁ v₂ => .sub (instantiateValueLvl what level v₁) (instantiateValueLvl what level v₂)
| .max v₁ v₂ => .max (instantiateValueLvl what level v₁) (instantiateValueLvl what level v₂)
| .lt v₁ v₂ => .lt (instantiateValueLvl what level v₁) (instantiateValueLvl what level v₂)
| .mul v₁ v₂ => .mul (instantiateValueLvl what level v₁) (instantiateValueLvl what level v₂)
| .eq v₁ v₂ => .eq (instantiateValueLvl what level v₁) (instantiateValueLvl what level v₂)
termination_by c => sizeOf c
decreasing_by
  all_goals simp
  all_goals grind

content: def instantiateValueLvl (what : Value) (level : Nat) : Value → Value
| var@(.var (.bvar bvarLevel)) => if bvarLevel = level then what else var
| .lam c => .lam <| instantiateComputationLvl what (level + 1) c
| .hdl h => .hdl <| instantiateHandlerLvl what level h
| .pair v₁ v₂ => .pair (instantiateValueLvl what level v₁) (instantiateValueLvl what level v₂)
| .recfun c => .recfun <| instantiateComputationLvl what (level + 2) c
| .string s => .string s
| .bool b => .bool b
| .unit => .unit
| .var v => .var v
| .num n => .num n
termination_by v => sizeOf v
decreasing_by
  all_goals simp
  all_goals grind

content: def instantiateHandlerLvl (what : Value) (level : Nat) : Handler → Handler
| ⟨ret, ops'⟩ =>
    ⟨instantiateComputationLvl what (level+1) ret, instantiateOps what level ops'⟩
termination_by h => sizeOf h
decreasing_by
  all_goals simp
  all_goals grind

content: def instantiateOps (what : Value) (level : Nat) : List OpClause → List OpClause
| [] => []
| ⟨op, body⟩ :: ls =>
  ⟨op, instantiateComputationLvl what (level+2) body⟩ :: instantiateOps what level ls
termination_by l => sizeOf l

content: structure OpClause where
  op : Name
   
  body : Computation
deriving Repr, BEq

content: inductive Computation where
| ret : Value → Computation
 
| opCall : Name → Value → Computation → Computation
 
| bind : Computation → Computation → Computation
| ite (val : Value) (trueBranch falseBranch : Computation)
| app : Value → Value → Computation
 
| handle : Value → Computation → Computation
| join : Value → Value → Computation
| fst : Value → Computation
| snd : Value → Computation
| add : Value → Value → Computation
| sub : Value → Value → Computation
| mul : Value → Value → Computation
| max : Value → Value → Computation
| lt : Value → Value → Computation
| eq : Value → Value → Computation
deriving BEq

content: inductive Value where
| var : Var → Value
| bool : Bool → Value
| string : String → Value
| num : Int → Value
| unit : Value
| pair : Value → Value → Value
 
| lam : Computation → Value
 
| recfun : Computation → Value
| hdl : Handler → Value
deriving BEq

content: structure Handler where
   
  ret : Computation
  ops : List OpClause
deriving Repr, BEq

content: inductive Var where
| fvar : Name → Var
| bvar : Nat → Var
deriving Repr, DecidableEq

content: abbrev Name := String

content: @[grind cases]
inductive Step : Computation → Computation → Prop
 
| beta v body : Step (.app (.lam body) v) (instantiateComp v body)
 
| recBeta v body : Step (.app (.recfun body) v) (instantiate2 (.recfun body) v body)
 
| iteTrue c₁ c₂ : Step (.ite (.bool true) c₁ c₂) c₁
 
| iteFalse c₁ c₂ : Step (.ite (.bool false) c₁ c₂) c₂
 
| bindStep c₁ c₁' c₂ (h : Step c₁ c₁') : Step (.bind c₁ c₂) (.bind c₁' c₂)
 
| bindReturn v c : Step (.bind (.ret v) c) (instantiateComp v c)
 
| bindOp op v body c : Step (.bind (.opCall op v body) c) (.opCall op v (.bind body c))
 
| handleInner h c₁ c₂ (h₁ : Step c₁ c₂) : Step (.handle (.hdl h) c₁) (.handle (.hdl h) c₂)
 
| handleReturn h v :
  Step (.handle (.hdl h) (.ret v)) (instantiateComp v h.ret)
 
| handleOpHit h op v body c (hop : h.lookup op = some ⟨op, c⟩) :
  Step (.handle (.hdl h) (.opCall op v body))
    (instantiate2 v (.lam (.handle (.hdl h) body)) c)
 
| handleOpMiss h op v body (hop : h.lookup op = none) :
  Step (.handle (.hdl h) (.opCall op v body)) (.opCall op v (.handle (.hdl h) body))
 
| join s₁ s₂ : Step (.join (.string s₁) (.string s₂)) (.ret (.string (strAppend s₁ s₂)))
 
| fstStep v₁ v₂ : Step (.fst (.pair v₁ v₂)) (.ret v₁)
 
| sndStep v₁ v₂ : Step (.snd (.pair v₁ v₂)) (.ret v₂)
| add v₁ v₂ : Step (.add (.num v₁) (.num v₂)) (.ret (.num (v₁ + v₂)))
| sub v₁ v₂ : Step (.sub (.num v₁) (.num v₂)) (.ret (.num (v₁ - v₂)))
| max v₁ v₂ : Step (.max (.num v₁) (.num v₂)) (.ret (.num (Max.max v₁ v₂)))
| lt v₁ v₂ : Step (.lt (.num v₁) (.num v₂)) (.ret (.bool (v₁ < v₂)))
| mul v₁ v₂ : Step (.mul (.num v₁) (.num v₂)) (.ret (.num (v₁ * v₂)))
| eq v₁ v₂ : Step (.eq v₁ v₂) (.ret (.bool (v₁ == v₂)))

content: def instantiate2 (arg cont : Value) (body : Computation) : Computation :=
  instantiateComputationLvl arg 1 (instantiateComputationLvl cont 0 body)

content: def strAppend : String → String → String
| "", s => s
| s, "" => s
| s₁, s₂ => s₁ ++ " " ++ s₂

content: @[grind cases]
inductive StepStar : Computation → Computation → Prop
| refl (c) : StepStar c c
| trans : Step c₁ c₂ → StepStar c₂ c₃ → StepStar c₁ c₃

content: def Handler.lookup (hdl : Handler) (name : Name) :=
  hdl.ops.find? (·.op == name)

content: infix:50 " ⤳ " => Step

content: infix:50 " ⤳⋆ " => StepStar

-- Repository lemmas used:
content: theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

-- Local definitions used:
content: def evalSingleStep : Computation → Option Computation
 
| .app (.lam body) v => some <| instantiateComp v body
 
| .app (.recfun body) v => some <| instantiate2 (.recfun body) v body
| .ite (.bool true) c₁ _ => some c₁
| .ite (.bool false) _ c₂ => some c₂
 
| .bind (.ret v) c => some <| instantiateComp v c
 
| .bind (.opCall op v body) c => some <| .opCall op v (.bind body c)
| .bind c₁ c₂ => (evalSingleStep c₁).map (fun c₁' => .bind c₁' c₂)
   
| .handle (.hdl h) (.ret v) => some <| instantiateComp v h.ret
| .handle (.hdl h) (.opCall op v body) =>
  match h.lookup op with
   
  | some ⟨_, c⟩ =>
    let cont := .lam (.handle (.hdl h) body)
    some <| instantiate2 v cont c
   
  | none => some <| .opCall op v (.handle (.hdl h) body)
| .handle (.hdl h) c =>
  (evalSingleStep c).map (fun c' => .handle (.hdl h) c')
| .join (.string s₁) (.string s₂) => some <| .ret (.string (strAppend s₁ s₂))
| .fst (.pair v₁ _) => some <| .ret v₁
| .snd (.pair _ v₂) => some <| .ret v₂
| .add (.num v₁) (.num v₂) => some <| .ret (.num (v₁ + v₂))
| .sub (.num v₁) (.num v₂) => some <| .ret (.num (v₁ - v₂))
| .max (.num v₁) (.num v₂) => some <| .ret (.num (Max.max v₁ v₂))
| .lt (.num v₁) (.num v₂) => some <| .ret (.bool (v₁ < v₂))
| .mul (.num v₁) (.num v₂) => some <| .ret (.num (v₁ * v₂))
| .eq v₁ v₂ => some <| .ret (.bool (v₁ == v₂))
| _ => none

content: def evalFuel : Nat → Computation → Option Computation
| 0, _ => none
| _+1, .ret v => some <| .ret v
| _+1, .opCall n v c => some <| .opCall n v c
| n+1, c =>
  match evalSingleStep c with
  | some c' => evalFuel n c'
  | none => none

-- Local lemmas used:
content: theorem evalSingleStep_sound {c c' : Computation} :
    evalSingleStep c = some c' → c ⤳ c'

-- Target theorem and proof:
theorem evalFuel_sound  : evalFuel n c = some v → c ⤳⋆ v
:= by
  induction h : n generalizing c with
  | zero => simp [evalFuel]
  | succ n ih =>
    cases hstep : evalSingleStep c with
    | none =>
      cases c <;> try grind [evalFuel]
      all_goals
      ( simp [evalFuel]
        intro h; rw [←h]; constructor)
    | some c' =>
      cases c with
      | ret | opCall =>
        simp [evalFuel]
        intro h; rw [←h]; constructor
      | _ =>
        simp [evalFuel, hstep]
        intro h
        exact StepStar.trans (evalSingleStep_sound hstep) (evalFuel_sound h)