-- 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 exec_stack_mono (s : Stack) (h : exec inst s₁ = some ⟨s₂, o⟩) :
    exec inst (s₁ ++ s) = some ⟨s₂ ++ s, o⟩

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_stack_mono (s : Stack) (h : exec prog s₁ = some s₂) :
    exec prog (s₁ ++ s) = s₂ ++ s

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

content: theorem lower_val_hEquiv (v : Value τ) : val v ≈ lower (val v)

content: theorem lower_and_hEquiv (hl : lhs ≈ lower lhs) (hr : rhs ≈ lower rhs) :
    and lhs rhs ≈ lower (and lhs rhs)

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

-- Target theorem and proof:
theorem lower_hEquiv (t : Term τ) : t ≈ lower t
:= by
  induction t
  case val          => exact lower_val_hEquiv _
  case and hl hr    => exact lower_and_hEquiv hl hr
  case ite hc hp hn => exact lower_ite_hEquiv hc hp hn