-- VerifiedCompiler.lean

inductive Ty
  | bool
  | nat

inductive Value : Ty → Type
  | bool : Bool → Value .bool
  | nat  : Nat  → Value .nat

inductive Term : Ty → Type
  | val (v : Value τ)                          : Term τ
  | ite (cond : Term .bool) (pos neg : Term τ) : Term τ
  | and (lhs rhs : Term .bool)                 : Term .bool

namespace Term

def eval : Term τ → Value τ
  | val v => v
  | ite cond pos neg =>
    match eval cond with
    | true  => eval pos
    | false => eval neg
  | and lhs rhs =>
    match eval lhs, eval rhs with
    | true, true => true
    | _,    _    => false

namespace Equiv

infixl:50 " ~ " => Equiv

end Equiv

end Term

open Term (eval)

inductive Instruction
  | const (n : Nat)
  | and
  | jmp (offset : Nat)
  | jez (offset : Nat)

abbrev Program := List Instruction

abbrev Stack := List Nat

def Nat.conj : Nat → Nat → Nat
  | 0, _ | _, 0 => 0
  | _, _        => 1

structure Instruction.Result where
  stack : Stack
  offset := 0

def Instruction.exec : Instruction → Stack → Option Instruction.Result
  | .const n,    stack        => some { stack := n :: stack }
  | .and,        r :: l :: tl => some { stack := (l.conj r) :: tl }
  | .and,        _            => none
  | .jmp offset, stack        => some { stack, offset }
  | .jez offset, 0 :: tl      => some { stack := tl, offset }
  | .jez _,      _ :: tl      => some { stack := tl }
  | .jez _,      _            => none

namespace Program

def goto : Program → Nat → Option Program
  | prog,    0          => prog
  | [],      _ + 1      => none
  | _ :: tl, offset + 1 => goto tl offset

def exec : Program → Stack → Option Stack
  | [],       stack => stack
  | hd :: tl, stack =>
    match Instruction.exec hd stack with
    | none => none
    | some { stack, offset } =>
      match h : goto tl offset with
      | none   => none
      | some p => exec p stack
termination_by p => p.length
decreasing_by simp +arith [goto_decreasing h]

end Program

def Value.toNat : Value τ → Nat
  | bool false => 0
  | bool true  => 1
  | nat n      => n

def Term.lower : Term τ → Program
  | val v            => [.const v.toNat]
  | and lhs rhs      => (lower lhs) ++ (lower rhs) ++ [.and]
  | ite cond pos neg =>
    let p := lower pos
    let n := lower neg
    lower cond ++ [.jez (p.length + 1)] ++ p ++ [.jmp n.length] ++ n

def HEquiv (t : Term τ) (prog : Program) : Prop :=
  prog.exec [] = some [t.eval.toNat]

infixl:60 " ≈ " => HEquiv

namespace Instruction

end Instruction

namespace Program

end Program

namespace Term

open Program List

open Instruction hiding exec

-- Repository definitions used:
content: ...

-- 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: inductive Ty
  | bool
  | nat

content: inductive Value : Ty → Type
  | bool : Bool → Value .bool
  | nat  : Nat  → Value .nat

content: inductive Term : Ty → Type
  | val (v : Value τ)                          : Term τ
  | ite (cond : Term .bool) (pos neg : Term τ) : Term τ
  | and (lhs rhs : Term .bool)                 : Term .bool

content: def eval : Term τ → Value τ
  | val v => v
  | ite cond pos neg =>
    match eval cond with
    | true  => eval pos
    | false => eval neg
  | and lhs rhs =>
    match eval lhs, eval rhs with
    | true, true => true
    | _,    _    => false

content: inductive Instruction
  | const (n : Nat)
  | and
  | jmp (offset : Nat)
  | jez (offset : Nat)

content: abbrev Program := List Instruction

content: abbrev Stack := List Nat

content: def Nat.conj : Nat → Nat → Nat
  | 0, _ | _, 0 => 0
  | _, _        => 1

content: structure Instruction.Result where
  stack : Stack
  offset := 0

content: def Instruction.exec : Instruction → Stack → Option Instruction.Result
  | .const n,    stack        => some { stack := n :: stack }
  | .and,        r :: l :: tl => some { stack := (l.conj r) :: tl }
  | .and,        _            => none
  | .jmp offset, stack        => some { stack, offset }
  | .jez offset, 0 :: tl      => some { stack := tl, offset }
  | .jez _,      _ :: tl      => some { stack := tl }
  | .jez _,      _            => none

content: def goto : Program → Nat → Option Program
  | prog,    0          => prog
  | [],      _ + 1      => none
  | _ :: tl, offset + 1 => goto tl offset

content: def exec : Program → Stack → Option Stack
  | [],       stack => stack
  | hd :: tl, stack =>
    match Instruction.exec hd stack with
    | none => none
    | some { stack, offset } =>
      match h : goto tl offset with
      | none   => none
      | some p => exec p stack
termination_by p => p.length
decreasing_by simp +arith [goto_decreasing h]

content: def Value.toNat : Value τ → Nat
  | bool false => 0
  | bool true  => 1
  | nat n      => n

content: def Term.lower : Term τ → Program
  | val v            => [.const v.toNat]
  | and lhs rhs      => (lower lhs) ++ (lower rhs) ++ [.and]
  | ite cond pos neg =>
    let p := lower pos
    let n := lower neg
    lower cond ++ [.jez (p.length + 1)] ++ p ++ [.jmp n.length] ++ n

content: def HEquiv (t : Term τ) (prog : Program) : Prop :=
  prog.exec [] = some [t.eval.toNat]

-- Local lemmas used:
content: @[simp]
theorem jmp_def (offset s) : exec (.jmp offset) s = some ⟨s, offset⟩

content: @[simp]
theorem jez_zero (offset s) : exec (.jez offset) (0 :: s) = some ⟨s, offset⟩

content: @[simp]
theorem jez_succ (n offset s) : exec (.jez offset) ((n + 1) :: s) = some ⟨s, 0⟩

content: @[simp]
theorem goto_zero (prog : Program) : goto prog 0 = some prog

content: @[simp]
theorem goto_suffix (prog₁ prog₂ : Program) : goto (prog₁ ++ prog₂) prog₁.length = some prog₂

content: @[simp]
theorem goto_end {prog : Program} (h : offset = prog.length) : goto prog offset = some []

content: theorem exec_goto (hi : i.exec s₁ = some ⟨s₂, offset⟩) (hg : goto prog₁ offset = some prog₂) :
    exec (i :: prog₁) s₁ = exec prog₂ s₂

content: theorem goto_mono (prog₂ : Program) (h : goto prog₁ offset = some prog₁') :
    goto (prog₁ ++ prog₂) offset = some (prog₁' ++ prog₂)

content: @[simp]
theorem exec_prog_mono (prog₂ : Program) (h : exec prog₁ s₁ = some s₂) :
    exec (prog₁ ++ prog₂) s₁ = exec prog₂ s₂

content: theorem eq_false_of_toNat_eq_zero {v : Value .bool} (h : v.toNat = 0) : v = false

content: theorem eq_true_of_toNat_eq_succ {v : Value .bool} (h : v.toNat = n + 1) : v = true

-- Target theorem and proof:
theorem lower_ite_hEquiv {cond : Term .bool} {pos neg : Term τ}
    (hc : cond ≈ lower cond) (hp : pos ≈ lower pos) (hn : neg ≈ lower neg) :
    ite cond pos neg ≈ lower (ite cond pos neg)
:= by
  rw [HEquiv, lower, append_assoc, append_assoc, append_assoc] at *
  -- Give names to terms needed later.
  let pl    := pos.lower.length + 1
  let nl    := neg.lower.length
  let prog₃ := [.jmp nl] ++ neg.lower
  let prog₂ := pos.lower ++ prog₃
  let prog₁ := [.jez pl] ++ prog₂
  -- Peel off the leading `lower cond`.
  rw [exec_prog_mono prog₁ hc]
  -- Continue differently depending on what's on top of the stack.
  cases h : cond.eval.toNat
  case zero =>
    -- Peel off the leading `jez`.
    have hg := goto_suffix (pos.lower ++ [jmp nl]) neg.lower
    simp only [length_append, length_singleton, append_assoc] at hg
    have he := exec_goto (jez_zero pl []) hg
    simp only [prog₁, singleton_append, he]
    -- Close the goal by establishing that `eval` yields `neg.eval`.
    simp_all only [prog₂, prog₃, eval, eq_false_of_toNat_eq_zero h]
  case succ n =>
    -- Peel off the leading `jez`.
    have he := exec_goto (jez_succ n pl []) (goto_zero prog₂)
    simp only [prog₁, singleton_append, he]
    -- Peel off the leading `lower pos`.
    rw [exec_prog_mono prog₃ hp]
    -- Peel off the leading `jmp`.
    have he := exec_goto (jmp_def nl [pos.eval.toNat]) (goto_end rfl)
    simp only [prog₃, singleton_append, he]
    -- Close the goal by establishing that `eval` yields `pos.eval`.
    simp only [eval, exec, eq_true_of_toNat_eq_succ h]