import LeanMLIR.Util
import LeanMLIR.Framework
import Mathlib.Tactic.Linarith

syntax "neg" : MLIR.Pretty.uniform_op

syntax "neg" : MLIR.Pretty.uniform_op

macro_rules
  | `(mlir_op| $res:mlir_op_operand = const ($x)
      $[: $outer_type]? ) => do
      let outer_type ← outer_type.getDM `(mlir_type| _)
      `(mlir_op| $res:mlir_op_operand = "const"()
          {val = $x:num : $outer_type} : ($outer_type) -> ($outer_type) )

macro_rules
  | `(mlir_op| $res:mlir_op_operand = li ($x)
     $[: $outer_type]?  ) => do
      let outer_type ← outer_type.getDM `(mlir_type| _ )
      `(mlir_op| $res:mlir_op_operand = "li"()
          {imm = $x:num : $outer_type } : ($outer_type) -> ($outer_type))

macro_rules
| `(mlir_op| $res:mlir_op_operand = $op1:MLIR.Pretty.RV.opWithImmediate $reg1 , $x : $t)  => do
    let some opName := MLIR.EDSL.Pretty.extractOpName op1.raw
      | Macro.throwUnsupported
    `(mlir_op| $res:mlir_op_operand = $opName ($reg1) {imm = $x:num : $t} : ($t) -> ($t) )

macro_rules
| `(mlir_op| $res:mlir_op_operand = $op1:MLIR.Pretty.RV.opWithShamt $reg1 , $x  : $t )  => do
    let some opName := MLIR.EDSL.Pretty.extractOpName op1.raw
      | Macro.throwUnsupported
    `(mlir_op| $res:mlir_op_operand = $opName ($reg1) {shamt = $x:num : $t}  : ($t) -> ($t) )

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

abbrev Index := ℕ

theorem not_lt_is_geq {a b: Nat} (NOT_LT: ¬ (a < b)): a >= b

import LeanMLIR.Framework

import LeanMLIR.Util

import Mathlib.Tactic.Linarith

namespace Tensor1D

abbrev Index := ℕ

structure Tensor1d (α : Type) [Inhabited α] where
  size : Index
  val :  Index → α
  spec : ∀ (ix: Index), ix >= size -> val ix = default

def Tensor1d.extract [Inhabited α] (t: Tensor1d α)
  (left: Index) (len: Index) : Tensor1d α :=
  let right := if (left + len) < t.size then left + len else 0
  let size := right - left
  { size := size,
    val := fun ix =>
    if left + len < t.size
    then if (ix < len) then t.val (ix + left) else default
    else default,
    spec := by admit /- proof elided -/

def Tensor1d.insertslice  [Inhabited α] (t: Tensor1d α)
  (sliceix: Nat)
  (slice : Tensor1d α) : Tensor1d α where
  size := if sliceix > t.size then 0 else t.size + slice.size
  val := fun ix =>
    if sliceix > t.size then default
    else if ix >= t.size + slice.size then default
    else
      let go (ix: Nat) : α :=
        if ix < sliceix then t.val sliceix
        else if ix < sliceix + slice.size then slice.val (ix - sliceix)
        else t.val (ix - (sliceix + slice.size))
      go ix
  spec := by admit /- proof elided -/

theorem extractslice_insertslice [Inhabited α]
  (t: Tensor1d α)
  (sliceix: Nat)
  (slice: Tensor1d α)
  (CORRECT: ((t.insertslice sliceix slice).extract sliceix slice.size).size ≠ 0)
  : (t.insertslice sliceix slice).extract sliceix slice.size = slice :=

:= by {
    simp[Tensor1d.insertslice, Tensor1d.extract]
    cases slice
    simp;
    rename_i slicesize sliceval spec
    by_cases A : (t.size < sliceix) <;> simp[A]

    case pos => simp[Tensor1d.insertslice, Tensor1d.extract, A] at CORRECT ;
    case neg =>
      have B : t.size >= sliceix := not_lt_is_geq A

      by_cases C:(sliceix < t.size) <;> simp[C]
      case neg => simp [Tensor1d.insertslice, Tensor1d.extract, A, C] at CORRECT
      case pos =>
          funext ix
          by_cases D: (ix < slicesize) <;> simp[D]
          case neg =>
            -- here we fail, because we do not know that 'slice' behaves like a
            -- real tensor that returns 'default' outside of its range.
            -- This is something we need to add into the spec of a Tensor.
            have E : ix >= slicesize := by simp[Index] at *; linarith
            simp[spec _ E]
          case pos =>
            try simp
            by_cases E:(t.size + slicesize <= ix + sliceix) <;> simp[E]
            case pos =>
              have CONTRA : False := by simp[Index] at *; linarith;
              simp at CONTRA;
            case neg =>
              intros K
              have CONTRA : False := by simp[Index] at *; linarith
              simp at CONTRA
}


import Lentil.Tactics.Structural
import Lentil.Gadgets.TheoremDeriving
import Lentil.Rules.Basic

syntax:15 tlafml:16 " → " tlafml:15 : tlafml

syntax:35 tlafml:36 " ∧ " tlafml:35 : tlafml

syntax:30 tlafml:31 " ∨ " tlafml:30 : tlafml

syntax:20 tlafml:21 " ↝ " tlafml:20 : tlafml

syntax:25 tlafml:26 " 𝑈 " tlafml:25 : tlafml

syntax:17 tlafml:18 " ⇒ " tlafml:17 : tlafml

syntax:max tlafml:max " |-tla- " tlafml:max : term

syntax:max tlafml:max " =tla= " tlafml:max : term

syntax "∀ " extBinder ", " tlafml:51 : tlafml

syntax tlafml_heading_op := "¬" <|> "□" <|> "◇" <|> "◯"

syntax:max tlafml_heading_op tlafml:40 : tlafml

syntax "[tlafml|" tlafml "]" : term

syntax "∃ " extBinder ", " tlafml:51 : tlafml

syntax:max "Enabled" term:40 : tlafml

syntax "⟨ " term " ⟩" : tlafml

macro "tla_unfold_simp" : tactic => `(tactic| (simp [tlasimp_def] at *))

syntax:max "|-tla- " tlafml:max : term

syntax:arg "𝒲ℱ" term:max : tlafml

syntax (name := tlaDerive) "tla_derive" : attr

macro "tla_unfold_simp'" : tactic => `(tactic| (tla_unfold_simp ; (try simp only [execsimp] at *)))

macro_rules
  | `([tlafml| ( $f:tlafml ) ]) => `([tlafml| $f ])
  | `([tlafml| ⌜ $t:term ⌝ ]) => `(TLA.state_pred $t)
  | `([tlafml| ⌞ $t:term ⌟ ]) => `(TLA.pure_pred $t)
  | `([tlafml| ⟨ $t:term ⟩ ]) => `(TLA.action_pred $t)
  | `([tlafml| ⊤ ]) => `(TLA.tla_true)
  | `([tlafml| ⊥ ]) => `(TLA.tla_false)
  | `([tlafml| $op:tlafml_heading_op $f:tlafml ]) => do
    let opterm ← match op with
      | `(tlafml_heading_op|¬) => `(TLA.tla_not)
      | `(tlafml_heading_op|□) => `(TLA.always)
      | `(tlafml_heading_op|◇) => `(TLA.eventually)
      | `(tlafml_heading_op|◯) => `(TLA.later)
      | _ => Macro.throwUnsupported
    `($opterm [tlafml| $f ])
  | `([tlafml| Enabled $t:term ]) => `(TLA.tla_enabled $t)
  | `([tlafml| $f1:tlafml → $f2:tlafml ]) => `(TLA.tla_implies [tlafml| $f1 ] [tlafml| $f2 ])
  | `([tlafml| $f1:tlafml ∧ $f2:tlafml ]) => `(TLA.tla_and [tlafml| $f1 ] [tlafml| $f2 ])
  | `([tlafml| $f1:tlafml ∨ $f2:tlafml ]) => `(TLA.tla_or [tlafml| $f1 ] [tlafml| $f2 ])
  | `([tlafml| $f1:tlafml 𝑈 $f2:tlafml ]) => `(TLA.tla_until [tlafml| $f1 ] [tlafml| $f2 ])
  | `([tlafml| ∀ $x:ident, $f:tlafml]) => `(TLA.tla_forall fun $x:ident => [tlafml| $f ])
  | `([tlafml| ∀ $x:ident : $t, $f:tlafml]) => `(TLA.tla_forall fun $x:ident : $t => [tlafml| $f ])
  | `([tlafml| ∃ $x:ident, $f:tlafml]) => `(TLA.tla_exists fun $x:ident => [tlafml| $f ])
  | `([tlafml| ∃ $x:ident : $t, $f:tlafml]) => `(TLA.tla_exists fun $x:ident : $t => [tlafml| $f ])
  | `([tlafml| $op:tlafml_bigop $x:binderIdent ∈ $l:term, $f:tlafml]) =>

    match op with
    | `(tlafml_bigop|⋀ ) => do `(TLA.tla_bigwedge (fun $(← binderIdentToFunBinder x) => [tlafml| $f ]) $l)
    | `(tlafml_bigop|⋁ ) => do `(TLA.tla_bigvee (fun $(← binderIdentToFunBinder x) => [tlafml| $f ]) $l)
    | _ => Macro.throwUnsupported
  | `([tlafml| $t:term ]) => `($t)

macro_rules
  | `([tlafml| $f1:tlafml ↝ $f2:tlafml ]) => `(TLA.leads_to [tlafml| $f1 ] [tlafml| $f2 ])
  | `([tlafml| $f1:tlafml ⇒ $f2:tlafml ]) => `(TLA.always_implies [tlafml| $f1 ] [tlafml| $f2 ])
  | `([tlafml| 𝒲ℱ $t:term ]) => `(TLA.weak_fairness $t)

macro_rules
  | `($f1:tlafml |-tla- $f2:tlafml) => `(TLA.pred_implies [tlafml| $f1 ] [tlafml| $f2 ])
  | `(|-tla- $f1:tlafml) => `(TLA.valid [tlafml| $f1 ])
  | `($f1:tlafml =tla= $f2:tlafml) => `([tlafml| $f1 ] = [tlafml| $f2 ])
  | `($e:term |=tla= $f:tlafml) => `(TLA.exec.satisfies [tlafml| $f ] $e)

macro_rules
  | `(tactic| try_unfold_at_all $idt:ident ) => `(tactic| (try unfold $idt at *) )
  | `(tactic| try_unfold_at_all $idt:ident $idts:ident* ) => `(tactic| (try unfold $idt at *) ; try_unfold_at_all $idts* )

exec.drop

def exec.drop {α : Type u} (k : Nat) (σ : exec α) : exec α := λ n => σ (n + k)

def tla_true {α : Type u} : pred α := pure_pred True

pred

def pred (σ : Type u) := exec σ → Prop

valid

def valid {α : Type u} (p : pred α) : Prop := ∀ (σ : exec α), σ.satisfies p

def tla_until {α : Type u} (p q : pred α) : pred α := λ σ => ∃ i, (q <| σ.drop i) ∧ ∀ j < i, (p <| σ.drop j)

def tla_false {α : Type u} : pred α := pure_pred False

def pure_pred {α : Type u} (p : Prop) : pred α := state_pred (fun _ => p)

def state_pred {σ : Type u} (f : σ → Prop) : pred σ :=
  fun e => f (e 0)

def tla_and {α : Type u} (p q : pred α) : pred α := fun σ => p σ ∧ q σ

def tla_exists {α : Sort u} {β : Type v} (p : α → pred β) : pred β := fun σ => ∃ x, p x σ

def tla_forall {α : Sort u} {β : Type v} (p : α → pred β) : pred β := fun σ => ∀ x, p x σ

def TLA.always_implies {α : Type u} (p q : TLA.pred α) : TLA.pred α := [tlafml| □ (p → q) ]

def tla_bigwedge {α : Type u} {β : Type v} {c} [Foldable c] (f : β → pred α) (s : c β) : pred α :=
  Foldable.fold tla_and tla_true f s

def TLA.weak_fairness {α : Type u} (a : action α) : pred α := [tlafml| □ ((□ (Enabled a)) → ◇ ⟨a⟩)]

action

def action (σ : Type u) := σ → σ → Prop

eventually

def eventually {α : Type u} (p : pred α) : pred α := λ σ => ∃ k, p <| σ.drop k

def tla_not {α : Type u} (p : pred α) : pred α := fun σ => ¬ p σ

def tla_or {α : Type u} (p q : pred α) : pred α := fun σ => p σ ∨ q σ

def pred_implies {α : Type u} (p q : pred α) : Prop := ∀ (σ : exec α), σ.satisfies p → σ.satisfies q

exec

def exec (σ : Type u) := Nat → σ

exec.satisfies

def exec.satisfies {α : Type u} (p : pred α) (σ : exec α) : Prop := p σ

def tla_enabled {α : Type u} (a : action α) : pred α := state_pred (enabled a)

enabled

def enabled {α : Type u} (a : action α) (s : α) : Prop := ∃ s', a s s'

def TLA.leads_to {α : Type u} (p q : TLA.pred α) : TLA.pred α := [tlafml| □ (p → ◇ q) ]

def action_pred {σ : Type u} (a : action σ) : pred σ :=
  fun e => a (e 0) (e 1)

def tla_implies {α : Type u} (p q : pred α) : pred α := fun σ => p σ → q σ

later

def later {α : Type u} (p : pred α) : pred α := λ σ => p <| σ.drop 1

always

def always {α : Type u} (p : pred α) : pred α := λ σ => ∀ k, p <| σ.drop k

def tla_bigvee {α : Type u} {β : Type v} {c} [Foldable c] (f : β → pred α) (s : c β) : pred α :=
  Foldable.fold tla_or tla_false f s

Foldable

class Foldable (c : Type u → Type v) where
  fold {α : Type u} {β : Type w} (op : β → β → β) [Std.Commutative op] [Std.Associative op]
    (b : β) (f : α → β) (s : c α) : β

@[tladual]
theorem always_eventually_or_distrib : (□ ◇ (p ∨ q)) =tla= (□ ◇ p ∨ □ ◇ q)

theorem dual_lemma (p q : pred σ) : ¬ p =tla= ¬ q → (p) =tla= (q)

theorem eventually_always_and_distrib : (◇ □ (p ∧ q)) =tla= (◇ □ p ∧ ◇ □ q)

theorem always_and : (□ (p ∧ q)) =tla= (□ p ∧ □ q)

theorem pred_eq_iff_iff (p q : pred σ) : (p) =tla= (q) ↔ (p) |-tla- (q) ∧ (q) |-tla- (p)

@[tladual]
theorem eventually_and_split : (◇ (p ∧ q)) |-tla- (◇ p ∧ ◇ q)

@[tladual]
theorem eventually_or : (◇ (p ∨ q)) =tla= (◇ p ∨ ◇ q)

theorem wf1' (p q init inv : σ → Prop) (next a : action σ)
  (hpuntilq : ∀ s s', p s → next s s' → p s' ∨ q s')
  (haq : ∀ s s', p s → next s s' → a s s' → q s')
  (henable : ∀ s, inv s → p s → enabled a s ∨ q s)
  (hinit_inv : ∀ s, init s → inv s)
  (hnext_inv : ∀ s s', next s s' → inv s → inv s') :
  (⌜ init ⌝ ∧ □ ⟨next⟩ ∧ 𝒲ℱ a) |-tla- (⌜ p ⌝ ↝ ⌜ q ⌝)

theorem wf_alt1 : (𝒲ℱ a) =tla= □ ◇ ((¬ Enabled a) ∨ □ ◇ ⟨a⟩)

theorem wf_alt1' : (𝒲ℱ a) =tla= □ ◇ ((¬ Enabled a) ∨ ⟨a⟩)

import Lentil.Rules.Basic

import Lentil.Tactics.Structural

import Lentil.Gadgets.TheoremDeriving

open Classical

namespace TLA

section wf

variable {σ : Type u}

section wf_def

variable {a : action σ}

end wf_def

@[tla_derive]
theorem wf1 (p q : pred σ) (next a : action σ) :
  ((p ∧ ⟨next⟩ ⇒ ◯ p ∨ ◯ q) ∧
   (p ∧ ⟨next⟩ ∧ ⟨a⟩ ⇒ ◯ q) ∧
   (p ⇒ Enabled a ∨ q) ∧
   (□ ⟨next⟩ ∧ 𝒲ℱ a)) |-tla- (p ↝ q) :=

:= by
  rw [wf_alt1']
  intro e ⟨hpuntilq, haq, henable, hnext, hwf_alt⟩ k hp
  specialize hwf_alt k ; rcases hwf_alt with ⟨k1, hwf_alt⟩
  -- know that: either `q` holds between `k` and `k + k1`, or `p` holds at `k1`
  -- use `henable` to know that if it is the latter case, then `q` must hold in the next step
  have htmp : (∃ k' ≤ k1, q <| e.drop (k + k')) ∨ (p <| e.drop (k + k1)) := by
    clear hwf_alt
    induction k1 with
    | zero => right ; assumption
    | succ n ih => {
      rw [← Nat.add_assoc]
      rcases ih with ⟨k', hle, ih⟩ | ih
      · left ; exists k' ; constructor ; omega ; apply ih
      · specialize hpuntilq _ ⟨ih, (hnext _)⟩
        rcases hpuntilq with hq | hq <;> tla_unfold_simp'
        · right ; apply hq
        · left ; exists (n + 1) ; aesop
    }
  rcases htmp with ⟨k', _, hq⟩ | hq <;> tla_unfold_simp'
  · aesop
  · rcases hwf_alt with hq2 | hq2
    · specialize henable _ hq ; aesop
    · exists (k1 + 1)
      specialize haq (k + k1) hq ; rw [← Nat.add_assoc] ; apply haq <;> aesop


notation:10 l:10 " ;; " r:11 => com.SEQ l r

ident

def ident := String deriving BEq, Repr, Hashable

aexp

inductive aexp : Type where
  | CONST (n : Int)
  | VAR (x : ident)
  | PLUS (a1 : aexp) (a2 : aexp)
  | MINUS (a1 : aexp) (s2 : aexp)

bexp

inductive bexp : Type where
  | TRUE
  | FALSE
  | EQUAL (a1 : aexp) (a2 : aexp)
  | LESSEQUAL (a1 : aexp) (a2 : aexp)
  | NOT (b1 : bexp)
  | AND (b1 : bexp) (b2 : bexp)

com

inductive com : Type where
  | SKIP
  | ASSIGN (x : ident) (a : aexp)
  | SEQ (c1 : com) (c2 : com)
  | IFTHENELSE (b : bexp) (c1 : com) (c2 : com)
  | WHILE (b : bexp) (c1 : com)

cont

@[grind] inductive cont where
| Kstop
| Kseq (c : com) (k : cont)
| Kwhile (b : bexp) (c : com) (k : cont)

store

def store : Type := ident → Int

update

@[grind] def update (x : ident) (v : Int) (s : store) : store :=
  fun y => if x == y then v else s y

star

@[grind] inductive star (R : α → α → Prop) : α → α → Prop where
  | star_refl : ∀ x : α, star R x x
  | star_step : ∀ {x y z}, R x y → star R y z → star R x z

plus

@[grind cases]
inductive plus (R : α → α → Prop) : α → α → Prop where
| plus_left : ∀ {a b c}, R a b → star R b c → plus R a c

grind_pattern plus.plus_left => star R b c, plus R a c

beval

@[grind] def beval (s : store) (b : bexp) : Bool :=
  match b with
  | .TRUE => true
  | .FALSE => false
  | .EQUAL a1 a2 => aeval s a1 = aeval s a2
  | .LESSEQUAL a1 a2 => aeval s a1 <= aeval s a2
  | .NOT b1 =>  !(beval s b1)
  | .AND b1 b2 => beval s b1 && beval s b2

aeval

@[grind] def aeval (s : store) (a : aexp) : Int :=
  match a with
  | .CONST n => n
  | .VAR x => s x
  | .PLUS a1 a2 => aeval s a1 + aeval s a2
  | .MINUS a1 a2 => aeval s a1 - aeval s a2

step

inductive step : com × cont × store -> com × cont × store -> Prop where
  | step_assign : ∀ x a k s,
      step (.ASSIGN x a, k, s) (.SKIP, k, update x (aeval s a) s)

  | step_seq : ∀ c1 c2 s k,
      step (.SEQ c1 c2, k, s) (c1, .Kseq c2 k, s)

  | step_ifthenelse : ∀ b c1 c2 k s,
      step (.IFTHENELSE b c1 c2, k, s) ((if beval s b then c1 else c2), k, s)

  | step_while_done : ∀ b c k s,
      beval s b = false ->
      step (.WHILE b c, k, s) (.SKIP, k, s)

  | step_while_true : ∀ b c k s,
      beval s b = true ->
      step (.WHILE b c, k, s) (c, .Kwhile b c k, s)

  | step_skip_seq : ∀ c k s,
      step (.SKIP, .Kseq c k, s) (c, k, s)

  | step_skip_while : ∀ b c k s,
      step (.SKIP, .Kwhile b c k, s) (.WHILE b c, k, s)

@[grind] theorem star_one (R : α → α → Prop) {a b : α} (h : R a b) : star R a b

@[grind] theorem plus_star {a b} (h : plus R a b) : star R a b

@[grind] theorem star_trans {α} (R : α → α → Prop) (a b : α) (sab : star R a b) : ∀ c : α, star R b c → star R a c

theorem plus_right : star R a b -> R b c -> plus R a c

stack

def stack : Type := List Int

measure'

@[grind =] theorem codelen_cons :
  ∀ i c, codelen (i :: c) = codelen c + 1

@[grind =] theorem codelen_app :
  ∀ c1 c2, codelen (c1 ++ c2) = codelen c1 + codelen c2

@[grind =>] theorem instr_a : ∀ i c2 c1 pc,
  pc = codelen c1 ->
  instr_at (c1 ++ (i :: c2) ) pc = .some i

@[grind] theorem code_at_app_right :
  ∀ C pc C1 C2,
  code_at C pc (C1 ++ C2) ->
  code_at C (pc + codelen C1) C2

@[grind] theorem code_at_to_instr_at : code_at C pc (c1 ++ i :: c2) → instr_at C (pc + codelen c1) = .some i

theorem compile_aexp_correct (C : List instr) (s : store) (a : aexp) (pc : Int) (stk : stack) :
  code_at C pc (compile_aexp a) →
  transitions C (pc, stk, s) (pc + codelen (compile_aexp a), aeval s a :: stk, s)

theorem compile_bexp_correct (C : List instr) (s : store) (b : bexp) (d1 d0 : Int) (pc : Int) (stk : stack) (h : code_at C pc (compile_bexp b d1 d0))  :
   transitions C
       (pc, stk, s)
       (pc + codelen (compile_bexp b d1 d0) + (if beval s b then d1 else d0), stk, s)

theorem compile_cont_Kseq_inv (C : List instr) (c : com) (k :cont) (pc : Int) (s : store) (H : compile_cont C (.Kseq c k) pc) :
  ∃ pc',
  star (transition C) (pc, [], s) (pc', [], s)
  ∧ code_at C pc' (compile_com c)
  ∧ compile_cont C k (pc' + codelen (compile_com c))

theorem compile_cont_Kwhile_inv (C : List instr) (b : bexp) (c : com) (k : cont) (pc : Int) (s : store) (H : compile_cont C (.Kwhile b c k) pc) :
  ∃ pc',
  plus (transition C) (pc, [], s) (pc', [], s)
  ∧ code_at C pc' (compile_com (.WHILE b c))
  ∧ compile_cont C k (pc' + codelen (compile_com (.WHILE b c)))

theorem match_config_skip (C : List instr) (k : cont) (s : store) (pc : Int) (H : compile_cont C k pc) :
 match_config C (.SKIP, k, s) (pc, [], s)

import LeroyCompilerVerificationCourse.Imp

@[grind] inductive instr : Type where
  | Iconst (n : Int)
  | Ivar (x : ident)
  | Isetvar (x : ident)
  | Iadd
  | Iopp
  | Ibranch (d : Int)
  | Ibeq (d1 : Int) (d0 : Int)
  | Ible (d1 : Int) (d0 : Int)
  | Ihalt
    deriving Repr

@[grind] def codelen (c : List instr) : Int := c.length

def stack : Type := List Int

def config : Type := Int × stack × store

@[grind] def instr_at (C : List instr) (pc : Int) : Option instr :=
  match C with
  | [] => .none
  | i :: C' => if pc = 0 then .some i else instr_at C' (pc - 1)

@[grind] inductive transition (C : List instr) : config → config → Prop where
  | trans_const : ∀ pc stk s n,
      instr_at C pc = .some (.Iconst n) →
      transition C (pc    , stk     , s)
                   (pc + 1, n :: stk, s)
  | trans_var : ∀ pc stk s x,
      instr_at C pc = .some (.Ivar x) ->
      transition C (pc    , stk       , s)
                   (pc + 1, s x :: stk, s)
  | trans_setvar : ∀ pc stk s x n,
      instr_at C pc = .some (.Isetvar x) ->
      transition C (pc    , n :: stk, s)
                   (pc + 1, stk     , update x n s)
  | trans_add : ∀ pc stk s n1 n2,
      instr_at C pc = .some (.Iadd) ->
      transition C (pc    , n2 :: n1 :: stk , s)
                   (pc + 1, (n1 + n2) :: stk, s)
  | trans_opp : ∀ pc stk s n,
      instr_at C pc = .some (.Iopp) ->
      transition C (pc    , n :: stk    , s)
                   (pc + 1, (- n) :: stk, s)
  | trans_branch : ∀ pc stk s d pc',
      instr_at C pc = .some (.Ibranch d) ->
      pc' = pc + 1 + d ->
      transition C (pc , stk, s)
                   (pc', stk, s)
  | trans_beq : ∀ pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = .some (.Ibeq d1 d0) ->
      pc' = pc + 1 + (if n1 = n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s)
  | trans_ble : ∀ pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = .some (.Ible d1 d0) ->
      pc' = pc + 1 + (if n1 ≤ n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s)

@[grind] def transitions (C : List instr) : config → config → Prop :=
  star (transition C)

@[grind] def compile_aexp (a : aexp) : List instr :=
  match a with
  | .CONST n => .Iconst n :: []
  | .VAR x => .Ivar x :: []
  | .PLUS a1 a2  => (compile_aexp a1) ++ (compile_aexp a2) ++ (.Iadd :: [])
  | .MINUS a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ (.Iopp :: .Iadd :: [])

@[grind] def compile_bexp (b : bexp) (d1 : Int) (d0 : Int) : List instr :=
  match b with
  | .TRUE => if d1 = 0 then [] else .Ibranch d1 :: []
  | .FALSE => if d0 = 0 then [] else .Ibranch d0 :: []
  | .EQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ .Ibeq d1 d0 :: []
  | .LESSEQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ .Ible d1 d0 :: []
  | .NOT b1 => compile_bexp b1 d0 d1
  | .AND b1 b2 =>
      let code2 := compile_bexp b2 d1 d0
      let code1 := compile_bexp b1 0 (codelen code2 + d0)
      code1 ++ code2

@[grind] def compile_com (c : com) : List instr :=
  match c with
  | .SKIP =>
      []
  | .ASSIGN x a =>
      compile_aexp a ++ .Isetvar x :: []
  | .SEQ c1 c2 =>
      compile_com c1 ++ compile_com c2
  | .IFTHENELSE b ifso ifnot =>
      let code_ifso := compile_com ifso
      let code_ifnot := compile_com ifnot
      compile_bexp b 0 (codelen code_ifso + 1)
      ++ code_ifso
      ++ .Ibranch (codelen code_ifnot)
      :: code_ifnot
  | .WHILE b body =>
      let code_body := compile_com body
      let code_test := compile_bexp b 0 (codelen code_body + 1)
      code_test
      ++ code_body
      ++ .Ibranch (- (codelen code_test + codelen code_body + 1)) :: []

@[grind] inductive code_at : List instr → Int → List instr → Prop where
  | code_at_intro : ∀ C1 C2 C3 pc,
      pc = codelen C1 ->
      code_at (C1 ++ C2 ++ C3) pc C2

inductive compile_cont (C : List instr) : cont -> Int -> Prop where
  | ccont_stop : ∀ pc,
      instr_at C pc = .some .Ihalt ->
      compile_cont C .Kstop pc
  | ccont_seq : ∀ c k pc pc',
      code_at C pc (compile_com c) ->
      pc' = pc + codelen (compile_com c) ->
      compile_cont C k pc' ->
      compile_cont C (.Kseq c k) pc
  | ccont_while : ∀ b c k pc d pc' pc'',
      instr_at C pc = .some (.Ibranch d) ->
      pc' = pc + 1 + d ->
      code_at C pc' (compile_com (.WHILE b c)) ->
      pc'' = pc' + codelen (compile_com (.WHILE b c)) ->
      compile_cont C k pc'' ->
      compile_cont C (.Kwhile b c k) pc
  | ccont_branch : ∀ d k pc pc',
      instr_at C pc = .some (.Ibranch d) ->
      pc' = pc + 1 + d ->
      compile_cont C k pc' ->
      compile_cont C k pc

inductive match_config (C : List instr) : com × cont × store -> config -> Prop where
  | match_config_intro : ∀ c k st pc,
      code_at C pc (compile_com c) ->
      compile_cont C k (pc + codelen (compile_com c)) ->
      match_config C (c, k, st) (pc, [], st)

def com_size (c : com) : Nat :=
  match c with
  | .SKIP => 1
  | .ASSIGN _ _ => 1
  | (c1 ;; c2) => (com_size c1 + com_size c2 + 1)
  | .IFTHENELSE _ c1 c2 => (com_size c1 + com_size c2 + 1)
  | .WHILE _ c1 => (com_size c1 + 1)

def cont_size (k : cont) : Nat :=
  match k with
  | .Kstop => 0
  | .Kseq c k' => (com_size c + cont_size k')
  | .Kwhile _ _ k' => cont_size k'

def measure' (impconf : com × cont × store) : Nat :=
  match impconf with
  | (c, k, _) => (com_size c + cont_size k)

theorem simulation_step :
  ∀ C impconf1 impconf2 machconf1,
  step impconf1 impconf2 ->
  match_config C impconf1 machconf1 ->
  ∃ machconf2,
      (plus (transition C) machconf1 machconf2
       \/ (star (transition C) machconf1 machconf2
           /\ (measure' impconf2 < measure' impconf1)))
   /\ match_config C impconf2 machconf2 :=

:= by
    intro C impconf1 impconf2 matchconf1 STEP MATCH
    cases MATCH
    case match_config_intro c k st pc h₁ h₂ =>
      rcases impconf2 with ⟨c' , k', s'⟩
      cases STEP
      next x a =>
        constructor
        constructor
        case h.left =>
          apply Or.intro_left
          apply plus_right
          apply compile_aexp_correct
          rotate_left
          exact a
          rotate_left
          · grind
          · apply transition.trans_setvar
            rotate_left
            exact x
            grind
        apply match_config_skip
        grind
      next c2 =>
        constructor
        constructor
        apply Or.intro_right
        constructor
        apply star.star_refl
        simp [measure', com_size, cont_size]
        grind
        constructor
        simp [compile_com] at h₁
        grind
        apply compile_cont.ccont_seq
        · grind
        rotate_right
        · exact pc + codelen (compile_com c') + codelen (compile_com c2)
        · rfl
        · grind
      next b c1 c2 =>
        generalize h₃ : compile_com c1 = code1
        generalize h₄ : compile_bexp b 0 (codelen code1 + 1) = codeb
        generalize h₅ : compile_com c2 = code2
        simp [compile_com, h₃, h₄, h₅] at h₁ h₂
        constructor
        constructor
        apply Or.intro_right
        constructor
        · apply compile_bexp_correct
          rotate_left
          · exact b
          · exact 0
          · exact (codelen code1 + 1)
          · grind
        · simp [measure', com_size]
          grind
        · rw [h₄]
          constructor
          · by_cases beval st b = true
            case pos isTrue =>
              simp [isTrue] at *
              grind
            case neg isFalse =>
              simp [isFalse] at *
              rw [h₅]
              have := @code_at_app_right C pc (codeb ++ code1 ++ [instr.Ibranch (codelen code2)]) code2 (by grind)
              simp [codelen_cons, codelen_app] at this
              simp [codelen] at *
              grind
          · by_cases beval st b = true
            case pos isTrue =>
              simp [isTrue] at *
              apply compile_cont.ccont_branch
              rotate_right
              · exact (pc + codelen (codeb ++ (code1 ++ instr.Ibranch (codelen code2) :: code2)))
              rotate_right
              · exact codelen code2
              any_goals grind
            case neg isFalse =>
              simp [isFalse] at *
              grind
      next b c isFalse =>
        generalize h₃ : compile_com c = codec
        generalize h₄ : (compile_bexp b 0 (codelen codec + 1)) = codeb
        constructor
        constructor
        apply Or.intro_right
        constructor
        · apply compile_bexp_correct
          rotate_left
          · exact b
          · exact 0
          · exact (codelen codec + 1)
          · grind
        · simp [measure', com_size]
          fun_induction com_size with grind
        · simp [isFalse]
          rw [h₄]
          simp [compile_com] at h₂ h₁
          rw [h₃, h₄] at h₂ h₁
          constructor
          · grind
          · grind
      next b isTrue =>
        generalize h₃ : compile_com c' = codec
        generalize h₄ : compile_bexp b 0 (codelen codec + 1) = codeb
        constructor
        constructor
        · apply Or.intro_right
          constructor
          · apply compile_bexp_correct
            rotate_left
            · exact b
            · exact 0
            · exact (codelen codec + 1)
            · grind
          · simp [measure', cont_size, com_size]
        · simp [isTrue]
          rw [h₄]
          constructor
          · simp [compile_com] at h₁
            rw [h₃, h₄] at h₁
            grind
          · simp [compile_com, h₃, h₄] at h₁ h₂
            apply compile_cont.ccont_while
            rotate_left 4
            · exact h₂
            · exact (-(codelen codeb + codelen codec + 1))
            rotate_left 3
            · simp [compile_com, h₃, h₄]
              exact h₁
            · grind
            · grind
            · grind
      next =>
        have := compile_cont_Kseq_inv C c' k' pc st (by simp [compile_com, codelen] at h₂; grind)
        apply Exists.elim this
        intro pc'
        intro ⟨w₁, w₂⟩
        exists (pc', [], st)
        constructor
        · apply Or.intro_right
          constructor
          · exact w₁
          · simp [measure', cont_size, com_size]
        · constructor
          · exact w₂.1
          · simp [compile_com, codelen] at h₂
            grind
      next b c =>
        have := compile_cont_Kwhile_inv C b c k' pc st (by simp [compile_com, codelen] at h₂; grind)
        apply Exists.elim this
        intro pc'
        intro ⟨ w₁, w₂ ⟩
        exists (pc', [], st)
        constructor
        · apply Or.intro_left
          · exact w₁
        · constructor
          · exact w₂.1
          · exact w₂.2


store

def store : Type := ident → Int

ident

def ident := String deriving BEq, Repr, Hashable

update

@[grind] def update (x : ident) (v : Int) (s : store) : store :=
  fun y => if x == y then v else s y

star

@[grind] inductive star (R : α → α → Prop) : α → α → Prop where
  | star_refl : ∀ x : α, star R x x
  | star_step : ∀ {x y z}, R x y → star R y z → star R x z

aexp

inductive aexp : Type where
  | CONST (n : Int)
  | VAR (x : ident)
  | PLUS (a1 : aexp) (a2 : aexp)
  | MINUS (a1 : aexp) (s2 : aexp)

bexp

inductive bexp : Type where
  | TRUE
  | FALSE
  | EQUAL (a1 : aexp) (a2 : aexp)
  | LESSEQUAL (a1 : aexp) (a2 : aexp)
  | NOT (b1 : bexp)
  | AND (b1 : bexp) (b2 : bexp)

com

inductive com : Type where
  | SKIP
  | ASSIGN (x : ident) (a : aexp)
  | SEQ (c1 : com) (c2 : com)
  | IFTHENELSE (b : bexp) (c1 : com) (c2 : com)
  | WHILE (b : bexp) (c1 : com)

cexec

@[grind] inductive cexec : store → com → store → Prop where
  | cexec_skip :
      cexec s .SKIP s
  | cexec_assign :
      cexec s (.ASSIGN x a) (update x (aeval s a) s)
  | cexec_seq :
      cexec s c1 s' -> cexec s' c2 s'' ->
      cexec s (.SEQ c1 c2) s''
  | cexec_ifthenelse :
      cexec s (if beval s b then c1 else c2) s' ->
      cexec s (.IFTHENELSE b c1 c2) s'
  | cexec_while_done :
      beval s b = false ->
      cexec s (.WHILE b c) s
  | cexec_while_loop :
      beval s b = true -> cexec s c s' -> cexec s' (.WHILE b c) s'' ->
      cexec s (.WHILE b c) s''

beval

@[grind] def beval (s : store) (b : bexp) : Bool :=
  match b with
  | .TRUE => true
  | .FALSE => false
  | .EQUAL a1 a2 => aeval s a1 = aeval s a2
  | .LESSEQUAL a1 a2 => aeval s a1 <= aeval s a2
  | .NOT b1 =>  !(beval s b1)
  | .AND b1 b2 => beval s b1 && beval s b2

aeval

@[grind] def aeval (s : store) (a : aexp) : Int :=
  match a with
  | .CONST n => n
  | .VAR x => s x
  | .PLUS a1 a2 => aeval s a1 + aeval s a2
  | .MINUS a1 a2 => aeval s a1 - aeval s a2

notation:10 l:10 " ;; " r:11 => com.SEQ l r

@[grind] theorem star_trans {α} (R : α → α → Prop) (a b : α) (sab : star R a b) : ∀ c : α, star R b c → star R a c

stack

def stack : Type := List Int

transitions

@[grind =] theorem codelen_cons :
  ∀ i c, codelen (i :: c) = codelen c + 1

@[grind =] theorem codelen_singleton : codelen [i] = 1

@[grind =] theorem codelen_app :
  ∀ c1 c2, codelen (c1 ++ c2) = codelen c1 + codelen c2

@[grind =>] theorem instr_a : ∀ i c2 c1 pc,
  pc = codelen c1 ->
  instr_at (c1 ++ (i :: c2) ) pc = .some i

@[grind] theorem code_at_app_right :
  ∀ C pc C1 C2,
  code_at C pc (C1 ++ C2) ->
  code_at C (pc + codelen C1) C2

@[grind] theorem code_at_to_instr_at : code_at C pc (c1 ++ i :: c2) → instr_at C (pc + codelen c1) = .some i

theorem compile_aexp_correct (C : List instr) (s : store) (a : aexp) (pc : Int) (stk : stack) :
  code_at C pc (compile_aexp a) →
  transitions C (pc, stk, s) (pc + codelen (compile_aexp a), aeval s a :: stk, s)

theorem compile_bexp_correct (C : List instr) (s : store) (b : bexp) (d1 d0 : Int) (pc : Int) (stk : stack) (h : code_at C pc (compile_bexp b d1 d0))  :
   transitions C
       (pc, stk, s)
       (pc + codelen (compile_bexp b d1 d0) + (if beval s b then d1 else d0), stk, s)

import LeroyCompilerVerificationCourse.Imp

@[grind] inductive instr : Type where
  | Iconst (n : Int)
  | Ivar (x : ident)
  | Isetvar (x : ident)
  | Iadd
  | Iopp
  | Ibranch (d : Int)
  | Ibeq (d1 : Int) (d0 : Int)
  | Ible (d1 : Int) (d0 : Int)
  | Ihalt
    deriving Repr

@[grind] def codelen (c : List instr) : Int := c.length

def stack : Type := List Int

def config : Type := Int × stack × store

@[grind] def instr_at (C : List instr) (pc : Int) : Option instr :=
  match C with
  | [] => .none
  | i :: C' => if pc = 0 then .some i else instr_at C' (pc - 1)

@[grind] inductive transition (C : List instr) : config → config → Prop where
  | trans_const : ∀ pc stk s n,
      instr_at C pc = .some (.Iconst n) →
      transition C (pc    , stk     , s)
                   (pc + 1, n :: stk, s)
  | trans_var : ∀ pc stk s x,
      instr_at C pc = .some (.Ivar x) ->
      transition C (pc    , stk       , s)
                   (pc + 1, s x :: stk, s)
  | trans_setvar : ∀ pc stk s x n,
      instr_at C pc = .some (.Isetvar x) ->
      transition C (pc    , n :: stk, s)
                   (pc + 1, stk     , update x n s)
  | trans_add : ∀ pc stk s n1 n2,
      instr_at C pc = .some (.Iadd) ->
      transition C (pc    , n2 :: n1 :: stk , s)
                   (pc + 1, (n1 + n2) :: stk, s)
  | trans_opp : ∀ pc stk s n,
      instr_at C pc = .some (.Iopp) ->
      transition C (pc    , n :: stk    , s)
                   (pc + 1, (- n) :: stk, s)
  | trans_branch : ∀ pc stk s d pc',
      instr_at C pc = .some (.Ibranch d) ->
      pc' = pc + 1 + d ->
      transition C (pc , stk, s)
                   (pc', stk, s)
  | trans_beq : ∀ pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = .some (.Ibeq d1 d0) ->
      pc' = pc + 1 + (if n1 = n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s)
  | trans_ble : ∀ pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = .some (.Ible d1 d0) ->
      pc' = pc + 1 + (if n1 ≤ n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s)

@[grind] def transitions (C : List instr) : config → config → Prop :=
  star (transition C)

@[grind] def compile_aexp (a : aexp) : List instr :=
  match a with
  | .CONST n => .Iconst n :: []
  | .VAR x => .Ivar x :: []
  | .PLUS a1 a2  => (compile_aexp a1) ++ (compile_aexp a2) ++ (.Iadd :: [])
  | .MINUS a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ (.Iopp :: .Iadd :: [])

@[grind] def compile_bexp (b : bexp) (d1 : Int) (d0 : Int) : List instr :=
  match b with
  | .TRUE => if d1 = 0 then [] else .Ibranch d1 :: []
  | .FALSE => if d0 = 0 then [] else .Ibranch d0 :: []
  | .EQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ .Ibeq d1 d0 :: []
  | .LESSEQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ .Ible d1 d0 :: []
  | .NOT b1 => compile_bexp b1 d0 d1
  | .AND b1 b2 =>
      let code2 := compile_bexp b2 d1 d0
      let code1 := compile_bexp b1 0 (codelen code2 + d0)
      code1 ++ code2

@[grind] def compile_com (c : com) : List instr :=
  match c with
  | .SKIP =>
      []
  | .ASSIGN x a =>
      compile_aexp a ++ .Isetvar x :: []
  | .SEQ c1 c2 =>
      compile_com c1 ++ compile_com c2
  | .IFTHENELSE b ifso ifnot =>
      let code_ifso := compile_com ifso
      let code_ifnot := compile_com ifnot
      compile_bexp b 0 (codelen code_ifso + 1)
      ++ code_ifso
      ++ .Ibranch (codelen code_ifnot)
      :: code_ifnot
  | .WHILE b body =>
      let code_body := compile_com body
      let code_test := compile_bexp b 0 (codelen code_body + 1)
      code_test
      ++ code_body
      ++ .Ibranch (- (codelen code_test + codelen code_body + 1)) :: []

@[grind] inductive code_at : List instr → Int → List instr → Prop where
  | code_at_intro : ∀ C1 C2 C3 pc,
      pc = codelen C1 ->
      code_at (C1 ++ C2 ++ C3) pc C2

theorem compile_com_correct_terminating (s s' : store) (c : com) (h₁ : cexec s c s') :
 ∀ C pc stk, code_at C pc (compile_com c) →
  transitions C
      (pc, stk, s)
      (pc + codelen (compile_com c), stk, s') :=

:= by
  induction h₁
  case cexec_skip =>
    intro C pc stk h
    unfold compile_com
    dsimp [codelen]
    simp only [Int.add_zero]
    apply star.star_refl
  case cexec_assign s' x a =>
    intro C pc stk h
    unfold compile_com
    apply star_trans
    · apply compile_aexp_correct (a := a)
      grind
    · apply star_one
      · have := @transition.trans_setvar C
        grind
  case cexec_seq s'2 c1 s1 c2 s2 cexec1 cexec2 c1_ih c2_ih =>
    intro C pc stk h
    apply star_trans
    · apply c1_ih
      grind
    · specialize c2_ih C (pc + codelen (compile_com c1)) stk
      simp [compile_com, codelen_app]
      simp [Int.add_assoc] at c2_ih
      apply c2_ih
      grind
  case cexec_ifthenelse s b c1 c2 s' cexec_h ih =>
    intro C pc stk
    generalize heq1 : compile_com c1 = code1
    generalize heq2 : compile_com c2 = code2
    generalize heq3 : compile_bexp b 0 (codelen code1 + 1) = code3
    simp [compile_com]
    rw [heq1, heq2, heq3]
    intro h
    apply star_trans
    · have := compile_bexp_correct C s b 0 (codelen code1 + 1) pc stk (by grind)
      apply this
    · by_cases beval s b = true
      case pos isTrue =>
        simp [isTrue]
        apply star_trans
        · apply ih
          grind
        · apply star_one
          · apply transition.trans_branch (d := codelen code2) <;> grind
      case neg isFalse =>
        simp [isFalse]
        rw [heq3]
        specialize ih C (pc + codelen code3 + (codelen code1 + 1)) stk
        simp [isFalse] at ih
        suffices h2 : code_at C (pc + codelen code3 + (codelen code1 + 1)) (compile_com c2) from by
          specialize ih h2
          simp [codelen_app, codelen_cons]
          have : (pc + codelen code3 + (codelen code1 + 1) + codelen (compile_com c2)) = (pc + (codelen code3 + (codelen code1 + (codelen code2 + 1)))) := by grind
          rw [this] at ih
          apply ih
        have := @code_at_app_right C pc (code3 ++ code1 ++ [instr.Ibranch (codelen code2)]) code2 (by simp[h])
        grind
  case cexec_while_done s b c1 isFalse =>
    intro C pc stk h
    generalize heq1 : compile_com c1 = code_body
    generalize heq2 : compile_bexp b 0 (codelen code_body + 1) = code_branch
    generalize heq3 : - (codelen code_branch + codelen code_body + 1) = d
    simp [compile_com]
    rw [heq1, heq2, heq3]
    simp [codelen_app, codelen_singleton]
    apply star_trans
    · apply compile_bexp_correct C s b 0 (codelen code_body + 1) pc stk (by grind)
    · grind
  case cexec_while_loop s b c1 s_intermediate s' isTrue cexec1 cexec2 ih1 ih2 =>
    intro C pc stk
    generalize heq1 : compile_com c1 = code_body
    generalize heq2 : compile_bexp b 0 (codelen code_body + 1) = code_branch
    generalize heq3 : - (codelen code_branch + codelen code_body + 1) = d
    simp [compile_com]
    rw [heq1, heq2, heq3]
    intro h
    apply star_trans
    · apply compile_bexp_correct C s b 0 (codelen code_body + 1) pc stk (by grind)
    · apply star_trans
      · apply ih1
        grind
      · apply star_trans
        · apply star_one
          apply transition.trans_branch (d := d)
          rotate_left
          rotate_left
          · exact (pc + codelen code_branch + codelen code_body + 1 + d)
          · grind
          · grind
        · specialize ih2 C (pc + codelen code_branch + codelen code_body + 1 + d) stk
          suffices h2 : code_at C (pc + codelen code_branch + codelen code_body + 1 + d) (compile_com (com.WHILE b c1)) from by
            specialize ih2 h2
            simp [compile_com] at ih2
            rw [heq1, heq2, heq3] at ih2
            simp [codelen_app]
            simp [codelen_app] at ih2
            have : (pc + codelen code_branch + codelen code_body + 1 + d +
      (codelen code_branch + (codelen code_body + codelen [instr.Ibranch d])) ) = (pc + (codelen code_branch + (codelen code_body + codelen [instr.Ibranch d]))) := by grind
            rw [←this]
            apply ih2
          grind


Store

def Store := Std.HashMap ident Int

Join

@[grind] def Join (S1 S2 : Store) : Store :=
  S1.filter (fun key _ => S2.get? key == S1.get? key)

Le

@[grind] def Le (S1 S2 : Store) : Prop :=
  ∀ x n, S2.get? x = .some n -> S1.get? x = .some n

Equal

def Equal (S1 S2 : Store) := Std.HashMap.Equiv S1 S2

com

inductive com : Type where
  | SKIP
  | ASSIGN (x : ident) (a : aexp)
  | SEQ (c1 : com) (c2 : com)
  | IFTHENELSE (b : bexp) (c1 : com) (c2 : com)
  | WHILE (b : bexp) (c1 : com)

Beval

@[grind] def Beval (S : Store) (b : bexp) : Option Bool :=
  match b with
  | .TRUE => .some true
  | .FALSE => .some false
  | .EQUAL a1 a2 => lift2 (fun m n => m == n) (Aeval S a1) (Aeval S a2)
  | .LESSEQUAL a1 a2 => lift2 (fun m n => m <= n) (Aeval S a1) (Aeval S a2)
  | .NOT b1 => lift1 (fun m => !m) (Beval S b1)
  | .AND b1 b2 => lift2 (fun m n => m && n) (Beval S b1) (Beval S b2)

@[grind] def lift1 {A B : Type} (f : A -> B) (o : Option A) : Option B :=
  match o with
  | .some x => .some (f x)
  | .none => .none

Aeval

@[grind] def Aeval (S : Store) (a : aexp) : Option Int :=
  match a with
  | .CONST n => .some n
  | .VAR x => S.get? x
  | .PLUS a1 a2 => lift2 (Int.add) (Aeval S a1) (Aeval S a2)
  | .MINUS a1 a2 => lift2 (Int.sub) (Aeval S a1) (Aeval S a2)

@[grind] def lift2 {A B C : Type} (f : A -> B -> C) (o1 : Option A) (o2 : Option B) : Option C :=
  match o1, o2 with
  | .some x1, .some x2 => .some (f x1 x2) | _, _ => .none

aexp

inductive aexp : Type where
  | CONST (n : Int)
  | VAR (x : ident)
  | PLUS (a1 : aexp) (a2 : aexp)
  | MINUS (a1 : aexp) (s2 : aexp)

ident

def ident := String deriving BEq, Repr, Hashable

bexp

inductive bexp : Type where
  | TRUE
  | FALSE
  | EQUAL (a1 : aexp) (a2 : aexp)
  | LESSEQUAL (a1 : aexp) (a2 : aexp)
  | NOT (b1 : bexp)
  | AND (b1 : bexp) (b2 : bexp)

Update

@[grind] def Update (x : ident) (N : Option Int) (S : Store) : Store :=
  match N with
  | .none => S.erase x
  | .some n => S.insert x n

notation:10 l:10 " ;; " r:11 => com.SEQ l r

theorem Le_Join_l : ∀ S1 S2, Le S1 (Join S1 S2)

wrapper

@[grind] theorem iterate_correct (x : α) (PRE : le x (F x)) (SMALL : ∀ z, le (F z) z -> le x z) (heq : y = iterate _ F x PRE SMALL ) : eq y (F y) ∧ ∀ z, le (F z) z → le y z

@[grind] theorem Eq_Le : ∀ S1 S2, Eq' S1 S2 → Le S1 S2

@[grind] theorem Le_trans : ∀ S1 S2 S3, Le S1 S2 → Le S2 S3 → Le S1 S3

theorem fixpoint_join_eq : Eq' (Join Init (F (fixpoint_join Init F) )) (fixpoint_join Init F)

theorem fixpoint_join_smallest :
  ∀ S, Le (Join Init (F S)) S -> Le (fixpoint_join Init F) S

@[grind] theorem Join_increasing :
  ∀ S1 S2 S3 S4,
  Le S1 S2 -> Le S3 S4 -> Le (Join S1 S3) (Join S2 S4)

import LeroyCompilerVerificationCourse.Imp

import LeroyCompilerVerificationCourse.Constprop

import Batteries.Data.List.Perm

@[grind] class OrderStruct (α : Sort u) where
  eq : α → α → Prop
  le : α → α → Prop
  beq : α → α → Bool
  le_trans : ∀ x y z, le x y -> le y z -> le x z
  beq_true' : ∀ x y : α, beq x y = true → eq x y := by admit /- proof elided -/

open OrderStruct

class Monotone (α : Sort u) (F : α → α) [OrderStruct α] where
  F_mon : ∀ {x y : α}, le x y → le (F x) (F y)

open Monotone

section FixpointExistence

variable (α : Sort u) (F : α → α) [OrderWithBot α]

open OrderStruct OrderWithBot

end FixpointExistence

section Iterate

variable (α : Sort u) [inst : OrderStruct α] (F : α → α) [Monotone α F]

open OrderStruct

@[grind] def iterate (x : α) (PRE : le x (F x)) (SMALL : ∀ z, le (F z) z -> le x z) : α :=
  if beq x (F x) then x else iterate (F x) (by admit /- proof elided -/
  ) (by admit /- proof elided -/
  )
  termination_by x
  decreasing_by
    grind [beq_false']

end Iterate

section Fixpoint

open OrderWithBot

variable {α : Sort u} [i : OrderWithBot α] (F : α → α) [Monotone α F]

end Fixpoint

section Constprop

open Std.HashMap

@[grind] def Eq' (S1 S2 : Store) : Prop := Equal S1 S2

def Eq'_sym : ∀ S1 S2, Eq' S1 S2 → Eq' S2 S1 :=

open OrderStruct

noncomputable instance : OrderStruct Store where
  eq := Equal
  le := Le
  beq (S1 S2 : Store) :=  Decidable.decide (Equal S1 S2)
  le_trans := Le_trans
  gt_wf := Gt_wf

end Constprop

section FixpointJoin

variable (Init : Store)

variable (F : Store → Store) [Monotone Store F]

instance : Monotone Store (fun x => Join Init (F x)) where
  F_mon := by admit /- proof elided -/

noncomputable def fixpoint_join : Store :=

end FixpointJoin

noncomputable instance wrapper (F : Store → Store) (F_mon : ∀ x y, le x y → le (F x) (F y)) : Monotone Store F where
  F_mon := by admit /- proof elided -/

noncomputable def fixpoint_join' (S : Store) (F : Store → Store) (F_mon : ∀ x y, le x y → le (F x) (F y)) :=

theorem fixpoint_join_increasing (_ : Store) (F : Store → Store) (F_mon : ∀ x y, le x y → le (F x) (F y)) (S1 S2 : Store) : le S1 S2 → le (fixpoint_join' S1 F F_mon) (fixpoint_join' S2 F F_mon) :=

:= by
  intro hyp
  apply @fixpoint_join_smallest S1 F (by grind [wrapper]) (fixpoint_join' S2 F F_mon)
  generalize heq : fixpoint_join' S2 F F_mon = fix2
  have : (Le (Join S2 (F fix2)) fix2) := by
    apply Eq_Le
    · have := @fixpoint_join_eq S2 F (by grind [wrapper])
      rw [←heq]
      apply this
  apply Le_trans
  rotate_left
  · apply this
  · apply Join_increasing
    · exact hyp
    · grind


ident

def ident := String deriving BEq, Repr, Hashable

aexp

inductive aexp : Type where
  | CONST (n : Int)
  | VAR (x : ident)
  | PLUS (a1 : aexp) (a2 : aexp)
  | MINUS (a1 : aexp) (s2 : aexp)

bexp

inductive bexp : Type where
  | TRUE
  | FALSE
  | EQUAL (a1 : aexp) (a2 : aexp)
  | LESSEQUAL (a1 : aexp) (a2 : aexp)
  | NOT (b1 : bexp)
  | AND (b1 : bexp) (b2 : bexp)

com

inductive com : Type where
  | SKIP
  | ASSIGN (x : ident) (a : aexp)
  | SEQ (c1 : com) (c2 : com)
  | IFTHENELSE (b : bexp) (c1 : com) (c2 : com)
  | WHILE (b : bexp) (c1 : com)

store

def store : Type := ident → Int

cexec

@[grind] inductive cexec : store → com → store → Prop where
  | cexec_skip :
      cexec s .SKIP s
  | cexec_assign :
      cexec s (.ASSIGN x a) (update x (aeval s a) s)
  | cexec_seq :
      cexec s c1 s' -> cexec s' c2 s'' ->
      cexec s (.SEQ c1 c2) s''
  | cexec_ifthenelse :
      cexec s (if beval s b then c1 else c2) s' ->
      cexec s (.IFTHENELSE b c1 c2) s'
  | cexec_while_done :
      beval s b = false ->
      cexec s (.WHILE b c) s
  | cexec_while_loop :
      beval s b = true -> cexec s c s' -> cexec s' (.WHILE b c) s'' ->
      cexec s (.WHILE b c) s''

beval

@[grind] def beval (s : store) (b : bexp) : Bool :=
  match b with
  | .TRUE => true
  | .FALSE => false
  | .EQUAL a1 a2 => aeval s a1 = aeval s a2
  | .LESSEQUAL a1 a2 => aeval s a1 <= aeval s a2
  | .NOT b1 =>  !(beval s b1)
  | .AND b1 b2 => beval s b1 && beval s b2

aeval

@[grind] def aeval (s : store) (a : aexp) : Int :=
  match a with
  | .CONST n => n
  | .VAR x => s x
  | .PLUS a1 a2 => aeval s a1 + aeval s a2
  | .MINUS a1 a2 => aeval s a1 - aeval s a2

update

@[grind] def update (x : ident) (v : Int) (s : store) : store :=
  fun y => if x == y then v else s y

notation:10 l:10 " ;; " r:11 => com.SEQ l r

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

Store

def Store := Std.HashMap ident Int

Update

@[grind] def num_iter : Nat := 20

Cexec

theorem mk_EQUAL_sound :
  ∀ s a1 a2, beval s (mk_EQUAL a1 a2) = (aeval s a1 = aeval s a2)

theorem mk_LESSEQUAL_sound :
  ∀ s a1 a2, beval s (mk_LESSEQUAL a1 a2) = (aeval s a1 <= aeval s a2)

theorem mk_NOT_sound :
  ∀ s b, beval s (mk_NOT b) = ¬ (beval s b)

theorem mk_AND_sound :
  ∀ s b1 b2, beval s (mk_AND b1 b2) = (beval s b1 ∧ beval s b2)

theorem cexec_mk_IFTHENELSE : ∀ s1 b c1 c2 s2,
  cexec s1 (if beval s1 b then c1 else c2) s2 ->
  cexec s1 (mk_IFTHENELSE b c1 c2) s2

theorem cexec_mk_WHILE_done : ∀ s1 b c,
  beval s1 b = false ->
  cexec s1 (mk_WHILE b c) s1

theorem cexec_mk_WHILE_loop : ∀ b c s1 s2 s3,
  beval s1 b = true -> cexec s1 c s2 -> cexec s2 (mk_WHILE b c) s3 ->
  cexec s1 (mk_WHILE b c) s3

theorem matches_Le : ∀ s S1 S2, Le S1 S2 -> matches' s S1 -> matches' s S2

theorem Le_Join_l : ∀ S1 S2, Le S1 (Join S1 S2)

theorem  Le_Join_r : ∀ S1 S2, Le S2 (Join S1 S2)

theorem Equal_Le : ∀ S1 S2, Equal S1 S2 -> Le S1 S2

theorem Beval_sound :
  ∀ s S, matches' s S ->
  ∀ b n, Beval S b = .some n -> beval s b = n

theorem fixpoint_sound (F : Store → Store) (init_S : Store) (h : S = fixpoint F init_S) :
  Le (F S) S

@[grind] theorem Cexec_sound :
  ∀ c s1 s2 S1,
  cexec s1 c s2 -> matches' s1 S1 -> matches' s2 (Cexec S1 c)

theorem cp_bexp_sound :
  ∀ s S, matches' s S ->
  ∀ b, beval s (cp_bexp S b) = beval s b

import LeroyCompilerVerificationCourse.Imp

import Std.Data.HashMap

open Classical in

@[grind] def mk_PLUS_CONST (a : aexp) (n : Int) : aexp :=
  if n = 0 then a else
  match a with
  | .CONST m => .CONST (m + n)
  | .PLUS a (.CONST m) => .PLUS a (.CONST (m + n))
  | _ => .PLUS a (.CONST n)

@[grind] def mk_PLUS (a1 a2 : aexp) : aexp :=
  match a1, a2 with
  | .CONST m, _ => mk_PLUS_CONST a2 m
  | _, .CONST m => mk_PLUS_CONST a1 m
  | .PLUS a1 (.CONST m1), .PLUS a2 (.CONST m2) => mk_PLUS_CONST (.PLUS a1 a2) (m1 + m2)
  | .PLUS a1 (.CONST m1), _ => mk_PLUS_CONST (.PLUS a1 a2) m1
  | _, .PLUS a2 (.CONST m2) => mk_PLUS_CONST (.PLUS a1 a2) m2
  | _, _ => .PLUS a1 a2

@[grind] def mk_MINUS (a1 a2 : aexp) : aexp :=
  match a1, a2 with
  | _, .CONST m => mk_PLUS_CONST a1 (-m)
  | .PLUS a1 (.CONST m1), .PLUS a2 (.CONST m2) => mk_PLUS_CONST (.MINUS a1 a2) (m1 - m2)
  | .PLUS a1 (.CONST m1), _ => mk_PLUS_CONST (.MINUS a1 a2) m1
  | _, .PLUS a2 (.CONST m2) => mk_PLUS_CONST (.MINUS a1 a2) (-m2)
  | _, _ => .MINUS a1 a2

@[grind] def mk_EQUAL (a1 a2 : aexp) : bexp :=
  match a1, a2 with
  | .CONST n1, .CONST n2 => if n1 = n2 then .TRUE else .FALSE
  | .PLUS a1 (.CONST n1), .CONST n2 => .EQUAL a1 (.CONST (n2 - n1))
  | _, _ => .EQUAL a1 a2

@[grind] def mk_LESSEQUAL (a1 a2 : aexp) : bexp :=
  match a1, a2 with
  | .CONST n1, .CONST n2 => if n1 <= n2 then .TRUE else .FALSE
  | .PLUS a1 (.CONST n1), .CONST n2 => .LESSEQUAL a1 (.CONST (n2 - n1))
  | _, _ => .LESSEQUAL a1 a2

@[grind] def mk_NOT (b : bexp) : bexp :=
  match b with
  | .TRUE => .FALSE
  | .FALSE => .TRUE
  | .NOT b => b
  | _ => .NOT b

@[grind] def mk_AND (b1 b2 : bexp) : bexp :=
  match b1, b2 with
  | .TRUE, _ => b2
  | _, .TRUE => b1
  | .FALSE, _ => .FALSE
  | _, .FALSE => .FALSE
  | _, _ => .AND b1 b2

@[grind] def mk_IFTHENELSE (b : bexp) (c1 c2 : com) : com :=
  match b with
  | .TRUE => c1
  | .FALSE => c2
  | _ => .IFTHENELSE b c1 c2

@[grind] def mk_WHILE (b : bexp) (c : com) : com :=
  match b with
  | .FALSE => .SKIP
  | _ => .WHILE b c

def Store := Std.HashMap ident Int

@[grind] def matches' (s : store) (S : Store) : Prop :=
  ∀ x n, S.get? x = .some n -> s x = n

@[grind] def Le (S1 S2 : Store) : Prop :=
  ∀ x n, S2.get? x = .some n -> S1.get? x = .some n

@[grind] def Top : Store := Std.HashMap.emptyWithCapacity

@[grind] def Join (S1 S2 : Store) : Store :=
  S1.filter (fun key _ => S2.get? key == S1.get? key)

def Equal (S1 S2 : Store) := Std.HashMap.Equiv S1 S2

@[grind] def lift1 {A B : Type} (f : A -> B) (o : Option A) : Option B :=
  match o with
  | .some x => .some (f x)
  | .none => .none

@[grind] def lift2 {A B C : Type} (f : A -> B -> C) (o1 : Option A) (o2 : Option B) : Option C :=
  match o1, o2 with
  | .some x1, .some x2 => .some (f x1 x2) | _, _ => .none

@[grind] def Aeval (S : Store) (a : aexp) : Option Int :=
  match a with
  | .CONST n => .some n
  | .VAR x => S.get? x
  | .PLUS a1 a2 => lift2 (Int.add) (Aeval S a1) (Aeval S a2)
  | .MINUS a1 a2 => lift2 (Int.sub) (Aeval S a1) (Aeval S a2)

@[grind] def Beval (S : Store) (b : bexp) : Option Bool :=
  match b with
  | .TRUE => .some true
  | .FALSE => .some false
  | .EQUAL a1 a2 => lift2 (fun m n => m == n) (Aeval S a1) (Aeval S a2)
  | .LESSEQUAL a1 a2 => lift2 (fun m n => m <= n) (Aeval S a1) (Aeval S a2)
  | .NOT b1 => lift1 (fun m => !m) (Beval S b1)
  | .AND b1 b2 => lift2 (fun m n => m && n) (Beval S b1) (Beval S b2)

@[grind] def Update (x : ident) (N : Option Int) (S : Store) : Store :=
  match N with
  | .none => S.erase x
  | .some n => S.insert x n

@[grind] noncomputable def fixpoint_rec (F : Store -> Store) (fuel : Nat) (S : Store) : Store :=
  match fuel with
  | 0 => Top
  | fuel + 1 =>
      let S' := F S
      if Equal S' S then S else fixpoint_rec F fuel S'

@[grind] def num_iter : Nat := 20

@[grind] noncomputable def fixpoint (F : Store -> Store) (init_S : Store) : Store :=
  fixpoint_rec F num_iter init_S

@[grind] noncomputable def Cexec (S : Store) (c : com) : Store :=
  match c with
  | .SKIP => S
  | .ASSIGN x a => Update x (Aeval S a) S
  | .SEQ c1 c2 => Cexec (Cexec S c1) c2
  | .IFTHENELSE b c1 c2 =>
      match Beval S b with
      | .some true => Cexec S c1
      | .some false => Cexec S c2
      | .none => Join (Cexec S c1) (Cexec S c2)
  | .WHILE _ c1 =>
      fixpoint (fun x => Join S (Cexec x c1)) S

@[grind =] def cp_aexp (S : Store) (a : aexp) : aexp :=
  match a with
  | .CONST n => .CONST n
  | .VAR x => match S.get? x with
    | .some n => .CONST n
    | .none => .VAR x
  | .PLUS a1 a2 => mk_PLUS (cp_aexp S a1) (cp_aexp S a2)
  | .MINUS a1 a2 => mk_MINUS (cp_aexp S a1) (cp_aexp S a2)

@[grind] def cp_bexp (S : Store) (b : bexp) : bexp :=
  match b with
  | .TRUE => .TRUE
  | .FALSE => .FALSE
  | .EQUAL a1 a2 => mk_EQUAL (cp_aexp S a1) (cp_aexp S a2)
  | .LESSEQUAL a1 a2 => mk_LESSEQUAL (cp_aexp S a1) (cp_aexp S a2)
  | .NOT b => mk_NOT (cp_bexp S b)
  | .AND b1 b2 => mk_AND (cp_bexp S b1) (cp_bexp S b2)

@[grind] noncomputable def cp_com (S : Store) (c : com) : com :=
  match c with
  | .SKIP => .SKIP
  | .ASSIGN x a =>
      .ASSIGN x (cp_aexp S a)
  | .SEQ c1 c2 =>
      .SEQ (cp_com S c1) (cp_com (Cexec S c1) c2)
  | .IFTHENELSE b c1 c2 =>
      mk_IFTHENELSE (cp_bexp S b) (cp_com S c1) (cp_com S c2)
  | .WHILE b c =>
      let sfix := Cexec S (.WHILE b c)
      mk_WHILE (cp_bexp sfix b) (cp_com sfix c)

theorem cp_com_correct_terminating :
  ∀ c s1 s2 S1,
  cexec s1 c s2 -> matches' s1 S1 -> cexec s1 (cp_com S1 c) s2 :=

:= by
    intro c s1 s2 S1 EXEC AG
    induction c generalizing s1 s2 S1
    any_goals grind
    case ASSIGN x a =>
      cases EXEC
      next =>
        have := @cexec.cexec_assign s1 x (cp_aexp S1 a)
        grind
    case IFTHENELSE b c1 c2 c1_ih c2_ih =>
      cases EXEC
      next =>
        apply cexec_mk_IFTHENELSE
        grind [cp_bexp_sound]
    case WHILE b c c_ih =>
      generalize heq1 : com.WHILE b c = loop
      generalize heq2 : Cexec S1 (.WHILE b c) = X
      have INNER : ∀ s1 c1 s2,
                 cexec s1 c1 s2 ->
                 c1 = .WHILE b c ->
                 matches' s1 X ->
                 cexec s1 (mk_WHILE (cp_bexp X b) (cp_com X c)) s2 := by
                  intro s1 c1
                  induction c1 generalizing s1 c
                  any_goals grind
                  case WHILE b1 c1 c1_ih  =>
                    intro s2 EXEC EQ AG1
                    injections heq1' heq2'
                    generalize heq : (com.WHILE b1 c1) = loop
                    rw [heq] at EXEC
                    induction EXEC
                    any_goals grind
                    case cexec_while_done isFalse =>
                      apply cexec_mk_WHILE_done
                      · grind [cp_bexp_sound]
                    case cexec_while_loop s3 b' c' s4 s5 isTrue EXEC2 EXEC3 a_ih a_ih2 =>
                      apply cexec_mk_WHILE_loop
                      · grind [cp_bexp_sound]
                      · apply c_ih
                        · injections heq4 heq5
                          rw [heq2'] at heq5
                          rw [←heq5] at EXEC2
                          exact EXEC2
                        · exact AG1
                      · apply a_ih2
                        rotate_left
                        · grind
                        · apply matches_Le
                          rw [←heq2]
                          simp [Cexec]
                          apply fixpoint_sound
                          rotate_left
                          · exact (fun x => Join S1 (Cexec x c))
                          · exact S1
                          rotate_left
                          · grind
                          · apply matches_Le
                            · apply Le_Join_r
                            · apply Cexec_sound
                              · rw [←heq2']
                                injections heq3 heq4
                                rw [heq4]
                                exact EXEC2
                              · grind
      rw [heq1] at EXEC
      induction EXEC
      any_goals grind
      case cexec_while_loop s3 b' c' s4 s5 isTrue EXEC1 EXEC2 ih1 ih2 =>
        injections heq3 heq4
        simp [cp_com]
        specialize INNER s3 (.WHILE b' c') s5
        rw [←heq3, ←heq4, heq2]
        apply INNER
        any_goals grind
        · rw [←heq2]
          simp [Cexec]
          apply matches_Le
          · apply fixpoint_sound
            rotate_left
            · exact (fun x => Join S1 (Cexec x c))
            · exact S1
            · grind
          · grind


ident

def ident := String deriving BEq, Repr, Hashable

store

def store : Type := ident → Int

aexp

inductive aexp : Type where
  | CONST (n : Int)
  | VAR (x : ident)
  | PLUS (a1 : aexp) (a2 : aexp)
  | MINUS (a1 : aexp) (s2 : aexp)

bexp

inductive bexp : Type where
  | TRUE
  | FALSE
  | EQUAL (a1 : aexp) (a2 : aexp)
  | LESSEQUAL (a1 : aexp) (a2 : aexp)
  | NOT (b1 : bexp)
  | AND (b1 : bexp) (b2 : bexp)

com

inductive com : Type where
  | SKIP
  | ASSIGN (x : ident) (a : aexp)
  | SEQ (c1 : com) (c2 : com)
  | IFTHENELSE (b : bexp) (c1 : com) (c2 : com)
  | WHILE (b : bexp) (c1 : com)

cexec

@[grind] inductive cexec : store → com → store → Prop where
  | cexec_skip :
      cexec s .SKIP s
  | cexec_assign :
      cexec s (.ASSIGN x a) (update x (aeval s a) s)
  | cexec_seq :
      cexec s c1 s' -> cexec s' c2 s'' ->
      cexec s (.SEQ c1 c2) s''
  | cexec_ifthenelse :
      cexec s (if beval s b then c1 else c2) s' ->
      cexec s (.IFTHENELSE b c1 c2) s'
  | cexec_while_done :
      beval s b = false ->
      cexec s (.WHILE b c) s
  | cexec_while_loop :
      beval s b = true -> cexec s c s' -> cexec s' (.WHILE b c) s'' ->
      cexec s (.WHILE b c) s''

beval

@[grind] def beval (s : store) (b : bexp) : Bool :=
  match b with
  | .TRUE => true
  | .FALSE => false
  | .EQUAL a1 a2 => aeval s a1 = aeval s a2
  | .LESSEQUAL a1 a2 => aeval s a1 <= aeval s a2
  | .NOT b1 =>  !(beval s b1)
  | .AND b1 b2 => beval s b1 && beval s b2

aeval

@[grind] def aeval (s : store) (a : aexp) : Int :=
  match a with
  | .CONST n => n
  | .VAR x => s x
  | .PLUS a1 a2 => aeval s a1 + aeval s a2
  | .MINUS a1 a2 => aeval s a1 - aeval s a2

update

@[grind] def update (x : ident) (v : Int) (s : store) : store :=
  fun y => if x == y then v else s y

notation:10 l:10 " ;; " r:11 => com.SEQ l r

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

Store

def Store := Std.HashMap ident Int

Update

@[grind] def num_iter : Nat := 20

Cexec

theorem matches_Le : ∀ s S1 S2, Le S1 S2 -> matches' s S1 -> matches' s S2

theorem Le_Join_l : ∀ S1 S2, Le S1 (Join S1 S2)

theorem  Le_Join_r : ∀ S1 S2, Le S2 (Join S1 S2)

theorem Equal_Le : ∀ S1 S2, Equal S1 S2 -> Le S1 S2

theorem Beval_sound :
  ∀ s S, matches' s S ->
  ∀ b n, Beval S b = .some n -> beval s b = n

theorem fixpoint_sound (F : Store → Store) (init_S : Store) (h : S = fixpoint F init_S) :
  Le (F S) S

import LeroyCompilerVerificationCourse.Imp

import Std.Data.HashMap

open Classical in

def Store := Std.HashMap ident Int

@[grind] def matches' (s : store) (S : Store) : Prop :=
  ∀ x n, S.get? x = .some n -> s x = n

@[grind] def Le (S1 S2 : Store) : Prop :=
  ∀ x n, S2.get? x = .some n -> S1.get? x = .some n

@[grind] def Top : Store := Std.HashMap.emptyWithCapacity

@[grind] def Join (S1 S2 : Store) : Store :=
  S1.filter (fun key _ => S2.get? key == S1.get? key)

def Equal (S1 S2 : Store) := Std.HashMap.Equiv S1 S2

@[grind] def lift1 {A B : Type} (f : A -> B) (o : Option A) : Option B :=
  match o with
  | .some x => .some (f x)
  | .none => .none

@[grind] def lift2 {A B C : Type} (f : A -> B -> C) (o1 : Option A) (o2 : Option B) : Option C :=
  match o1, o2 with
  | .some x1, .some x2 => .some (f x1 x2) | _, _ => .none

@[grind] def Aeval (S : Store) (a : aexp) : Option Int :=
  match a with
  | .CONST n => .some n
  | .VAR x => S.get? x
  | .PLUS a1 a2 => lift2 (Int.add) (Aeval S a1) (Aeval S a2)
  | .MINUS a1 a2 => lift2 (Int.sub) (Aeval S a1) (Aeval S a2)

@[grind] def Beval (S : Store) (b : bexp) : Option Bool :=
  match b with
  | .TRUE => .some true
  | .FALSE => .some false
  | .EQUAL a1 a2 => lift2 (fun m n => m == n) (Aeval S a1) (Aeval S a2)
  | .LESSEQUAL a1 a2 => lift2 (fun m n => m <= n) (Aeval S a1) (Aeval S a2)
  | .NOT b1 => lift1 (fun m => !m) (Beval S b1)
  | .AND b1 b2 => lift2 (fun m n => m && n) (Beval S b1) (Beval S b2)

@[grind] def Update (x : ident) (N : Option Int) (S : Store) : Store :=
  match N with
  | .none => S.erase x
  | .some n => S.insert x n

@[grind] noncomputable def fixpoint_rec (F : Store -> Store) (fuel : Nat) (S : Store) : Store :=
  match fuel with
  | 0 => Top
  | fuel + 1 =>
      let S' := F S
      if Equal S' S then S else fixpoint_rec F fuel S'

@[grind] def num_iter : Nat := 20

@[grind] noncomputable def fixpoint (F : Store -> Store) (init_S : Store) : Store :=
  fixpoint_rec F num_iter init_S

@[grind] noncomputable def Cexec (S : Store) (c : com) : Store :=
  match c with
  | .SKIP => S
  | .ASSIGN x a => Update x (Aeval S a) S
  | .SEQ c1 c2 => Cexec (Cexec S c1) c2
  | .IFTHENELSE b c1 c2 =>
      match Beval S b with
      | .some true => Cexec S c1
      | .some false => Cexec S c2
      | .none => Join (Cexec S c1) (Cexec S c2)
  | .WHILE _ c1 =>
      fixpoint (fun x => Join S (Cexec x c1)) S

@[grind] theorem Cexec_sound :
  ∀ c s1 s2 S1,
  cexec s1 c s2 -> matches' s1 S1 -> matches' s2 (Cexec S1 c) :=

:= by
    intro c
    induction c
    next =>
      intro s1 s2 S1 EXEC
      cases EXEC
      grind
    next x a =>
      intro s1 s2 S1 EXEC
      cases EXEC
      grind
    next c1 c2 c1_ih c2_ih =>
      grind
    next b c1 c2 c1_ih c2_ih =>
      intro s1 s2 S1 EXEC
      cases EXEC
      next EXEC =>
        by_cases beval s1 b
        case pos h =>
          unfold Cexec
          intro h2
          have := Beval_sound s1 S1 h2 b
          split <;> grind
        case neg h =>
          simp [h] at EXEC
          intro h2
          unfold Cexec
          have := Beval_sound s1 S1 h2 b
          split <;> grind
    case WHILE b c c1_ih =>
      intro s1 s2 S1 EXEC MATCHES
      generalize eq1 : (fun x => Join S1 (Cexec x c)) = F
      generalize eq2 : fixpoint F S1 = X
      have INNER : ∀ s1 c1 s2,
                 cexec s1 c1 s2 ->
                 c1 = .WHILE b c ->
                 matches' s1 X ->
                 matches' s2 X := by
                  intro s3 c1 s4 EXEC2 EQ AG
                  induction EXEC2
                  any_goals grind
                  case cexec_while_loop s' b' c' s5 s6 EXEC2 EXEC3 EXEC4 _ a_ih2 =>
                    apply a_ih2
                    · grind
                    · apply matches_Le
                      rotate_right
                      · exact F X
                      · exact @fixpoint_sound X F S1 (by grind)
                      · rw [←eq2, ←eq1]
                        simp
                        apply matches_Le
                        apply Le_Join_r
                        rw [eq1, eq2]
                        apply c1_ih
                        injections EQ
                        rename_i eq1 eq2
                        rw [eq2] at EXEC3
                        exact EXEC3
                        exact AG
      unfold Cexec
      rw [eq1, eq2]
      apply INNER
      · apply EXEC
      · rfl
      · apply matches_Le
        have := @fixpoint_sound X F
        apply this
        rotate_left
        · exact S1
        rotate_left
        · grind
        · rw [←eq1]
          simp
          apply matches_Le
          · apply Le_Join_l
          · exact MATCHES


store

def store : Type := ident → Int

ident

def ident := String deriving BEq, Repr, Hashable

update

@[grind] def update (x : ident) (v : Int) (s : store) : store :=
  fun y => if x == y then v else s y

star

@[grind] inductive star (R : α → α → Prop) : α → α → Prop where
  | star_refl : ∀ x : α, star R x x
  | star_step : ∀ {x y z}, R x y → star R y z → star R x z

aexp

inductive aexp : Type where
  | CONST (n : Int)
  | VAR (x : ident)
  | PLUS (a1 : aexp) (a2 : aexp)
  | MINUS (a1 : aexp) (s2 : aexp)

bexp

inductive bexp : Type where
  | TRUE
  | FALSE
  | EQUAL (a1 : aexp) (a2 : aexp)
  | LESSEQUAL (a1 : aexp) (a2 : aexp)
  | NOT (b1 : bexp)
  | AND (b1 : bexp) (b2 : bexp)

beval

@[grind] def beval (s : store) (b : bexp) : Bool :=
  match b with
  | .TRUE => true
  | .FALSE => false
  | .EQUAL a1 a2 => aeval s a1 = aeval s a2
  | .LESSEQUAL a1 a2 => aeval s a1 <= aeval s a2
  | .NOT b1 =>  !(beval s b1)
  | .AND b1 b2 => beval s b1 && beval s b2

aeval

@[grind] def aeval (s : store) (a : aexp) : Int :=
  match a with
  | .CONST n => n
  | .VAR x => s x
  | .PLUS a1 a2 => aeval s a1 + aeval s a2
  | .MINUS a1 a2 => aeval s a1 - aeval s a2

@[grind] theorem star_trans {α} (R : α → α → Prop) (a b : α) (sab : star R a b) : ∀ c : α, star R b c → star R a c

stack

def stack : Type := List Int

transitions

@[grind =] theorem codelen_app :
  ∀ c1 c2, codelen (c1 ++ c2) = codelen c1 + codelen c2

@[grind =>] theorem instr_a : ∀ i c2 c1 pc,
  pc = codelen c1 ->
  instr_at (c1 ++ (i :: c2) ) pc = .some i

@[grind] theorem code_at_to_instr_at : code_at C pc (c1 ++ i :: c2) → instr_at C (pc + codelen c1) = .some i

theorem compile_aexp_correct (C : List instr) (s : store) (a : aexp) (pc : Int) (stk : stack) :
  code_at C pc (compile_aexp a) →
  transitions C (pc, stk, s) (pc + codelen (compile_aexp a), aeval s a :: stk, s)

import LeroyCompilerVerificationCourse.Imp

@[grind] inductive instr : Type where
  | Iconst (n : Int)
  | Ivar (x : ident)
  | Isetvar (x : ident)
  | Iadd
  | Iopp
  | Ibranch (d : Int)
  | Ibeq (d1 : Int) (d0 : Int)
  | Ible (d1 : Int) (d0 : Int)
  | Ihalt
    deriving Repr

@[grind] def codelen (c : List instr) : Int := c.length

def stack : Type := List Int

def config : Type := Int × stack × store

@[grind] def instr_at (C : List instr) (pc : Int) : Option instr :=
  match C with
  | [] => .none
  | i :: C' => if pc = 0 then .some i else instr_at C' (pc - 1)

@[grind] inductive transition (C : List instr) : config → config → Prop where
  | trans_const : ∀ pc stk s n,
      instr_at C pc = .some (.Iconst n) →
      transition C (pc    , stk     , s)
                   (pc + 1, n :: stk, s)
  | trans_var : ∀ pc stk s x,
      instr_at C pc = .some (.Ivar x) ->
      transition C (pc    , stk       , s)
                   (pc + 1, s x :: stk, s)
  | trans_setvar : ∀ pc stk s x n,
      instr_at C pc = .some (.Isetvar x) ->
      transition C (pc    , n :: stk, s)
                   (pc + 1, stk     , update x n s)
  | trans_add : ∀ pc stk s n1 n2,
      instr_at C pc = .some (.Iadd) ->
      transition C (pc    , n2 :: n1 :: stk , s)
                   (pc + 1, (n1 + n2) :: stk, s)
  | trans_opp : ∀ pc stk s n,
      instr_at C pc = .some (.Iopp) ->
      transition C (pc    , n :: stk    , s)
                   (pc + 1, (- n) :: stk, s)
  | trans_branch : ∀ pc stk s d pc',
      instr_at C pc = .some (.Ibranch d) ->
      pc' = pc + 1 + d ->
      transition C (pc , stk, s)
                   (pc', stk, s)
  | trans_beq : ∀ pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = .some (.Ibeq d1 d0) ->
      pc' = pc + 1 + (if n1 = n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s)
  | trans_ble : ∀ pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = .some (.Ible d1 d0) ->
      pc' = pc + 1 + (if n1 ≤ n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s)

@[grind] def transitions (C : List instr) : config → config → Prop :=
  star (transition C)

@[grind] def compile_aexp (a : aexp) : List instr :=
  match a with
  | .CONST n => .Iconst n :: []
  | .VAR x => .Ivar x :: []
  | .PLUS a1 a2  => (compile_aexp a1) ++ (compile_aexp a2) ++ (.Iadd :: [])
  | .MINUS a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ (.Iopp :: .Iadd :: [])

@[grind] def compile_bexp (b : bexp) (d1 : Int) (d0 : Int) : List instr :=
  match b with
  | .TRUE => if d1 = 0 then [] else .Ibranch d1 :: []
  | .FALSE => if d0 = 0 then [] else .Ibranch d0 :: []
  | .EQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ .Ibeq d1 d0 :: []
  | .LESSEQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ .Ible d1 d0 :: []
  | .NOT b1 => compile_bexp b1 d0 d1
  | .AND b1 b2 =>
      let code2 := compile_bexp b2 d1 d0
      let code1 := compile_bexp b1 0 (codelen code2 + d0)
      code1 ++ code2

@[grind] inductive code_at : List instr → Int → List instr → Prop where
  | code_at_intro : ∀ C1 C2 C3 pc,
      pc = codelen C1 ->
      code_at (C1 ++ C2 ++ C3) pc C2

theorem compile_bexp_correct (C : List instr) (s : store) (b : bexp) (d1 d0 : Int) (pc : Int) (stk : stack) (h : code_at C pc (compile_bexp b d1 d0))  :
   transitions C
       (pc, stk, s)
       (pc + codelen (compile_bexp b d1 d0) + (if beval s b then d1 else d0), stk, s) :=

:= by
    induction b generalizing d1 d0 pc
    next =>
      simp [compile_bexp, beval]
      by_cases d1 = 0
      case pos is_zero =>
        simp [is_zero, codelen]
        apply star.star_refl
      case neg is_not_zero =>
        apply star_one
        grind
    next =>
      simp [compile_bexp, beval]
      by_cases d0 = 0
      case pos is_zero =>
        simp [is_zero, codelen]
        apply star.star_refl
      case neg is_not_zero =>
        apply star_one
        simp [is_not_zero, codelen]
        grind
    next a1 a2 =>
      simp [compile_bexp, beval]
      apply star_trans
      · apply compile_aexp_correct (a := a1)
        grind
      · apply star_trans
        · apply compile_aexp_correct (a := a2)
          grind
        · apply star_one
          · apply transition.trans_beq (d1 := d1) (d0 := d0) <;> grind
    next a1 a2 =>
      simp [compile_bexp, beval]
      apply star_trans
      · apply compile_aexp_correct (a := a1)
        grind
      · apply star_trans
        · apply compile_aexp_correct (a := a2)
          grind
        · apply star_one
          · apply transition.trans_ble (d1 := d1) (d0 := d0) <;> grind
    next b1 ih =>
      grind
    next b1 b2 b1_ih b2_ih =>
      generalize heq1 : compile_bexp b2 d1 d0 = code2
      generalize heq2 : compile_bexp b1 0 (codelen code2 + d0) = code1
      unfold compile_bexp
      simp [heq1, heq2]
      apply star_trans
      · apply b1_ih (d1 := 0) (d0 := codelen code2 + d0)
        grind
      · by_cases beval s b1 = true
        case pos isTrue =>
          simp [isTrue]
          rw [heq2]
          simp [beval, isTrue]
          specialize b2_ih d1 d0 (pc + codelen code1)
          rw [heq1] at b2_ih
          simp [compile_bexp, heq1, heq2] at h
          specialize b2_ih (by grind)
          simp [codelen_app]
          simp [Int.add_assoc] at *
          exact b2_ih
        case neg isFalse =>
          grind


ident

def ident := String deriving BEq, Repr, Hashable

aexp

inductive aexp : Type where
  | CONST (n : Int)
  | VAR (x : ident)
  | PLUS (a1 : aexp) (a2 : aexp)
  | MINUS (a1 : aexp) (s2 : aexp)

bexp

inductive bexp : Type where
  | TRUE
  | FALSE
  | EQUAL (a1 : aexp) (a2 : aexp)
  | LESSEQUAL (a1 : aexp) (a2 : aexp)
  | NOT (b1 : bexp)
  | AND (b1 : bexp) (b2 : bexp)

com

inductive com : Type where
  | SKIP
  | ASSIGN (x : ident) (a : aexp)
  | SEQ (c1 : com) (c2 : com)
  | IFTHENELSE (b : bexp) (c1 : com) (c2 : com)
  | WHILE (b : bexp) (c1 : com)

store

def store : Type := ident → Int

cexec

@[grind] inductive cexec : store → com → store → Prop where
  | cexec_skip :
      cexec s .SKIP s
  | cexec_assign :
      cexec s (.ASSIGN x a) (update x (aeval s a) s)
  | cexec_seq :
      cexec s c1 s' -> cexec s' c2 s'' ->
      cexec s (.SEQ c1 c2) s''
  | cexec_ifthenelse :
      cexec s (if beval s b then c1 else c2) s' ->
      cexec s (.IFTHENELSE b c1 c2) s'
  | cexec_while_done :
      beval s b = false ->
      cexec s (.WHILE b c) s
  | cexec_while_loop :
      beval s b = true -> cexec s c s' -> cexec s' (.WHILE b c) s'' ->
      cexec s (.WHILE b c) s''

beval

@[grind] def beval (s : store) (b : bexp) : Bool :=
  match b with
  | .TRUE => true
  | .FALSE => false
  | .EQUAL a1 a2 => aeval s a1 = aeval s a2
  | .LESSEQUAL a1 a2 => aeval s a1 <= aeval s a2
  | .NOT b1 =>  !(beval s b1)
  | .AND b1 b2 => beval s b1 && beval s b2

aeval

@[grind] def aeval (s : store) (a : aexp) : Int :=
  match a with
  | .CONST n => n
  | .VAR x => s x
  | .PLUS a1 a2 => aeval s a1 + aeval s a2
  | .MINUS a1 a2 => aeval s a1 - aeval s a2

update

@[grind] def update (x : ident) (v : Int) (s : store) : store :=
  fun y => if x == y then v else s y

notation:10 l:10 " ;; " r:11 => com.SEQ l r

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

IdentSet

abbrev IdentSet := Std.HashSet ident

agree

@[grind =] theorem subset_def (a b : IdentSet) : a ⊆ b ↔ ∀ x ∈ a, x ∈ b

theorem live_while_charact (b : bexp) (c : com) (L L' : IdentSet)
  (eq : L' = live (.WHILE b c) L) :
  (fv_bexp b) ⊆ L' ∧ L ⊆ L' ∧ (live c L') ⊆ L'

theorem beval_agree :
  ∀ L s1 s2, agree L s1 s2 ->
  ∀ b, (fv_bexp b) ⊆ L -> beval s1 b = beval s2 b

import LeroyCompilerVerificationCourse.Imp

import Std.Data.HashSet

abbrev IdentSet := Std.HashSet ident

@[grind] def fv_aexp (a : aexp) : IdentSet :=
  match a with
  | .CONST _ => ∅
  | .VAR v => Std.HashSet.instSingleton.singleton v
  | .PLUS a1 a2 =>  (fv_aexp a1) ∪ (fv_aexp a2)
  | .MINUS a1 a2 => (fv_aexp a1) ∪ (fv_aexp a2)

@[grind] def fv_bexp (b : bexp) : IdentSet :=
  match b with
  | .TRUE => ∅
  | .FALSE => ∅
  | .EQUAL a1 a2 => (fv_aexp a1) ∪ (fv_aexp a2)
  | .LESSEQUAL a1 a2 => (fv_aexp a1) ∪ (fv_aexp a2)
  | .NOT b1 => fv_bexp b1
  | .AND b1 b2 => (fv_bexp b1) ∪ (fv_bexp b2)

@[grind] def fv_com (c : com) : IdentSet :=
  match c with
  | .SKIP => ∅
  | .ASSIGN _ a => fv_aexp a
  | .SEQ c1 c2 => (fv_com c1) ∪ (fv_com c2)
  | .IFTHENELSE b c1 c2 => (fv_bexp b) ∪ ((fv_com c1) ∪ (fv_com c2))
  | .WHILE b c => (fv_bexp b) ∪ (fv_com c)

@[grind] noncomputable def deadcode_fixpoint_rec (F : IdentSet → IdentSet) (default : IdentSet) (fuel : Nat) (x : IdentSet) : IdentSet :=
  match fuel with
  | 0 => default
  | fuel + 1 =>
      let x' := F x
      if x' ⊆ x then x else deadcode_fixpoint_rec F default fuel x'

@[grind] noncomputable def deadcode_fixpoint (F : IdentSet → IdentSet) (default : IdentSet) : IdentSet :=
  deadcode_fixpoint_rec F default 20 ∅

@[grind] noncomputable def live (c : com) (L : IdentSet) : IdentSet :=
  match c with
  | .SKIP => L
  | .ASSIGN x a =>
      if x ∈ L
      then (L.erase x) ∪ (fv_aexp a)
      else L
  | .SEQ c1 c2 =>
      live c1 (live c2 L)
  | .IFTHENELSE b c1 c2 =>
       (fv_bexp b) ∪ ((live c1 L) ∪ (live c2 L))
  | .WHILE b c =>
      let L' := (fv_bexp b) ∪  L
      let default := (fv_com (.WHILE b c)) ∪ L
      deadcode_fixpoint (fun x => L' ∪ (live c x)) default

@[grind] noncomputable def dce (c : com) (L : IdentSet) : com :=
  match c with
  | .SKIP => .SKIP
  | .ASSIGN x a => if x ∈ L then .ASSIGN x a else .SKIP
  | .SEQ c1 c2 => .SEQ (dce c1 (live c2 L)) (dce c2 L)
  | .IFTHENELSE b c1 c2 => .IFTHENELSE b (dce c1 L) (dce c2 L)
  | .WHILE b c => .WHILE b (dce c (live (.WHILE b c) L))

@[grind] def agree (L : IdentSet) (s1 s2 : store) : Prop :=
  ∀ x, x  ∈ L -> s1 x = s2 x

theorem dce_correct_terminating :
  ∀ s c s', cexec s c s' ->
  ∀ L s1, agree (live c L) s s1 ->
  ∃ s1', cexec s1 (dce c L) s1' /\ agree L s' s1' :=

:= by
    intro s c s' EXEC
    induction EXEC
    any_goals grind
    case cexec_while_loop s1 b c1 s2 s3 isTrue EX1 EX2 a_ih a_ih2 =>
      intro L s4 hyp
      have ⟨t1, ht1, ht2⟩ :=  a_ih (live (.WHILE b c1) L) s4 (by grind)
      have ⟨u1, hu1, hu2⟩ :=  a_ih2 L t1 ht2
      exists u1
      constructor
      rotate_right
      · exact hu2
      · apply cexec.cexec_while_loop
        · have := beval_agree (live (com.WHILE b c1) L) s1 s4
          grind
        · exact ht1
        · grind
    case cexec_assign s2 x a=>
      intro L s3 AG
      simp [live] at AG
      by_cases x ∈ L
      case neg notIn =>
        exists s3
        grind
      case pos isIn =>
        exists (update x (aeval s3 a) s3)
        grind
    case cexec_ifthenelse s2 b c1 c2 s3 EXEC ih =>
      intro L s4 AG
      simp [dce]
      have EQ : beval s2 b = beval s4 b := by
        apply beval_agree
        · apply AG
        · grind
      by_cases beval s2 b = true
      case pos isTrue =>
        specialize ih L s4
        grind
      case neg isFalse =>
        specialize ih L s4
        grind
    case cexec_while_done s2 b c isFalse =>
      intro L s1 AG
      have ⟨h1, h2, h3⟩ := live_while_charact b c L (live (com.WHILE b c) L) (by grind)
      have EQ : beval s2 b = beval s1 b := by
        apply beval_agree
        · apply AG
        · grind
      exists s1
      grind
    case cexec_seq => grind [-subset_def] -- TODO: what does wrong?


store

def store : Type := ident → Int

ident

def ident := String deriving BEq, Repr, Hashable

star

@[grind] inductive star (R : α → α → Prop) : α → α → Prop where
  | star_refl : ∀ x : α, star R x x
  | star_step : ∀ {x y z}, R x y → star R y z → star R x z

aexp

inductive aexp : Type where
  | CONST (n : Int)
  | VAR (x : ident)
  | PLUS (a1 : aexp) (a2 : aexp)
  | MINUS (a1 : aexp) (s2 : aexp)

aeval

@[grind] def aeval (s : store) (a : aexp) : Int :=
  match a with
  | .CONST n => n
  | .VAR x => s x
  | .PLUS a1 a2 => aeval s a1 + aeval s a2
  | .MINUS a1 a2 => aeval s a1 - aeval s a2

@[grind] theorem star_trans {α} (R : α → α → Prop) (a b : α) (sab : star R a b) : ∀ c : α, star R b c → star R a c

stack

def stack : Type := List Int

transitions

@[grind =>] theorem instr_a : ∀ i c2 c1 pc,
  pc = codelen c1 ->
  instr_at (c1 ++ (i :: c2) ) pc = .some i

@[grind] theorem code_at_to_instr_at : code_at C pc (c1 ++ i :: c2) → instr_at C (pc + codelen c1) = .some i

import LeroyCompilerVerificationCourse.Imp

@[grind] inductive instr : Type where
  | Iconst (n : Int)
  | Ivar (x : ident)
  | Isetvar (x : ident)
  | Iadd
  | Iopp
  | Ibranch (d : Int)
  | Ibeq (d1 : Int) (d0 : Int)
  | Ible (d1 : Int) (d0 : Int)
  | Ihalt
    deriving Repr

@[grind] def codelen (c : List instr) : Int := c.length

def stack : Type := List Int

def config : Type := Int × stack × store

@[grind] def instr_at (C : List instr) (pc : Int) : Option instr :=
  match C with
  | [] => .none
  | i :: C' => if pc = 0 then .some i else instr_at C' (pc - 1)

@[grind] inductive transition (C : List instr) : config → config → Prop where
  | trans_const : ∀ pc stk s n,
      instr_at C pc = .some (.Iconst n) →
      transition C (pc    , stk     , s)
                   (pc + 1, n :: stk, s)
  | trans_var : ∀ pc stk s x,
      instr_at C pc = .some (.Ivar x) ->
      transition C (pc    , stk       , s)
                   (pc + 1, s x :: stk, s)
  | trans_setvar : ∀ pc stk s x n,
      instr_at C pc = .some (.Isetvar x) ->
      transition C (pc    , n :: stk, s)
                   (pc + 1, stk     , update x n s)
  | trans_add : ∀ pc stk s n1 n2,
      instr_at C pc = .some (.Iadd) ->
      transition C (pc    , n2 :: n1 :: stk , s)
                   (pc + 1, (n1 + n2) :: stk, s)
  | trans_opp : ∀ pc stk s n,
      instr_at C pc = .some (.Iopp) ->
      transition C (pc    , n :: stk    , s)
                   (pc + 1, (- n) :: stk, s)
  | trans_branch : ∀ pc stk s d pc',
      instr_at C pc = .some (.Ibranch d) ->
      pc' = pc + 1 + d ->
      transition C (pc , stk, s)
                   (pc', stk, s)
  | trans_beq : ∀ pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = .some (.Ibeq d1 d0) ->
      pc' = pc + 1 + (if n1 = n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s)
  | trans_ble : ∀ pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = .some (.Ible d1 d0) ->
      pc' = pc + 1 + (if n1 ≤ n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s)

@[grind] def transitions (C : List instr) : config → config → Prop :=
  star (transition C)

@[grind] def compile_aexp (a : aexp) : List instr :=
  match a with
  | .CONST n => .Iconst n :: []
  | .VAR x => .Ivar x :: []
  | .PLUS a1 a2  => (compile_aexp a1) ++ (compile_aexp a2) ++ (.Iadd :: [])
  | .MINUS a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ (.Iopp :: .Iadd :: [])

@[grind] inductive code_at : List instr → Int → List instr → Prop where
  | code_at_intro : ∀ C1 C2 C3 pc,
      pc = codelen C1 ->
      code_at (C1 ++ C2 ++ C3) pc C2

theorem compile_aexp_correct (C : List instr) (s : store) (a : aexp) (pc : Int) (stk : stack) :
  code_at C pc (compile_aexp a) →
  transitions C (pc, stk, s) (pc + codelen (compile_aexp a), aeval s a :: stk, s) :=

:= by
    induction a generalizing C pc stk
    next =>
      unfold transitions
      grind
    next =>
      intro a
      apply star_one
      grind
    next a1 a2 a1_ih a2_ih =>
      simp [aeval, compile_aexp]
      intro a
      apply star_trans
      · apply a1_ih
        grind
      · apply star_trans
        · apply a2_ih
          grind
        · apply star_one
          cases a
          next c1 c3 a =>
            have h1 := instr_a
            have h2 := @transition.trans_add
            grind
    next a1 a2 a1_ih a2_ih =>
      simp [aeval, compile_aexp]
      intro a
      apply star_trans
      · apply a1_ih
        grind
      · apply star_trans
        · apply a2_ih
          grind
        · apply star_trans
          · apply star_one
            · apply transition.trans_opp
              grind
          · apply star_one
            · have := @code_at_to_instr_at C pc (compile_aexp a1 ++ compile_aexp a2 ++ [instr.Iopp])
              have := @transition.trans_add
              grind


store

def store : Type := ident → Int

red

@[grind] theorem red_seq_steps (c2 c c' : com) (s s' : store) : star red (c, s) (c', s') → star red ((c;;c2), s) ((c';;c2), s')

import LeroyCompilerVerificationCourse.Sequences

def ident := String deriving BEq, Repr, Hashable

inductive aexp : Type where
  | CONST (n : Int)
  | VAR (x : ident)
  | PLUS (a1 : aexp) (a2 : aexp)
  | MINUS (a1 : aexp) (s2 : aexp)

def store : Type := ident → Int

@[grind] def aeval (s : store) (a : aexp) : Int :=
  match a with
  | .CONST n => n
  | .VAR x => s x
  | .PLUS a1 a2 => aeval s a1 + aeval s a2
  | .MINUS a1 a2 => aeval s a1 - aeval s a2

inductive bexp : Type where
  | TRUE
  | FALSE
  | EQUAL (a1 : aexp) (a2 : aexp)
  | LESSEQUAL (a1 : aexp) (a2 : aexp)
  | NOT (b1 : bexp)
  | AND (b1 : bexp) (b2 : bexp)

@[grind] def beval (s : store) (b : bexp) : Bool :=
  match b with
  | .TRUE => true
  | .FALSE => false
  | .EQUAL a1 a2 => aeval s a1 = aeval s a2
  | .LESSEQUAL a1 a2 => aeval s a1 <= aeval s a2
  | .NOT b1 =>  !(beval s b1)
  | .AND b1 b2 => beval s b1 && beval s b2

inductive com : Type where
  | SKIP
  | ASSIGN (x : ident) (a : aexp)
  | SEQ (c1 : com) (c2 : com)
  | IFTHENELSE (b : bexp) (c1 : com) (c2 : com)
  | WHILE (b : bexp) (c1 : com)

notation:10 l:10 " ;; " r:11 => com.SEQ l r

@[grind] def update (x : ident) (v : Int) (s : store) : store :=
  fun y => if x == y then v else s y

@[grind] inductive cexec : store → com → store → Prop where
  | cexec_skip :
      cexec s .SKIP s
  | cexec_assign :
      cexec s (.ASSIGN x a) (update x (aeval s a) s)
  | cexec_seq :
      cexec s c1 s' -> cexec s' c2 s'' ->
      cexec s (.SEQ c1 c2) s''
  | cexec_ifthenelse :
      cexec s (if beval s b then c1 else c2) s' ->
      cexec s (.IFTHENELSE b c1 c2) s'
  | cexec_while_done :
      beval s b = false ->
      cexec s (.WHILE b c) s
  | cexec_while_loop :
      beval s b = true -> cexec s c s' -> cexec s' (.WHILE b c) s'' ->
      cexec s (.WHILE b c) s''

@[grind] inductive red : com × store → com × store → Prop where
  | red_assign : ∀ x a s,
      red (.ASSIGN x a, s) (.SKIP, update x (aeval s a) s)
  | red_seq_done : ∀ c s,
      red (.SEQ .SKIP c, s) (c, s)
  | red_seq_step : ∀ c1 c s1 c2 s2,
      red (c1, s1) (c2, s2) →
      red (.SEQ c1 c, s1) (.SEQ c2 c, s2)
  | red_ifthenelse : ∀ b c1 c2 s,
      red (.IFTHENELSE b c1 c2, s) ((if beval s b then c1 else c2), s)
  | red_while_done : ∀ b c s,
      beval s b = false →
      red (.WHILE b c, s) (.SKIP, s)
  | red_while_loop : ∀ b c s,
      beval s b = true →
      red (.WHILE b c, s) (.SEQ c (.WHILE b c), s)

theorem cexec_to_reds (s s' : store) (c : com) : cexec s c s' → star red (c, s) (.SKIP, s') :=

:= by
  intro h
  induction h
  any_goals grind
  case cexec_seq ih1 ih2  =>
    apply star_trans
    · apply red_seq_steps
      exact ih1
    · apply star.star_step
      apply red.red_seq_done
      grind
  case cexec_while_loop ih1 ih2 =>
    apply star_trans
    · apply star_one
      · apply red.red_while_loop
        · grind
    · apply star_trans
      · apply red_seq_steps
        · exact ih1
      · apply star_trans
        rotate_left
        · apply ih2
        · grind


ident

def ident := String deriving BEq, Repr, Hashable

aexp

inductive aexp : Type where
  | CONST (n : Int)
  | VAR (x : ident)
  | PLUS (a1 : aexp) (a2 : aexp)
  | MINUS (a1 : aexp) (s2 : aexp)

store

def store : Type := ident → Int

star

@[grind] inductive star (R : α → α → Prop) : α → α → Prop where
  | star_refl : ∀ x : α, star R x x
  | star_step : ∀ {x y z}, R x y → star R y z → star R x z

cont

@[grind] inductive cont where
| Kstop
| Kseq (c : com) (k : cont)
| Kwhile (b : bexp) (c : com) (k : cont)

step

inductive step : com × cont × store -> com × cont × store -> Prop where
  | step_assign : ∀ x a k s,
      step (.ASSIGN x a, k, s) (.SKIP, k, update x (aeval s a) s)

  | step_seq : ∀ c1 c2 s k,
      step (.SEQ c1 c2, k, s) (c1, .Kseq c2 k, s)

  | step_ifthenelse : ∀ b c1 c2 k s,
      step (.IFTHENELSE b c1 c2, k, s) ((if beval s b then c1 else c2), k, s)

  | step_while_done : ∀ b c k s,
      beval s b = false ->
      step (.WHILE b c, k, s) (.SKIP, k, s)

  | step_while_true : ∀ b c k s,
      beval s b = true ->
      step (.WHILE b c, k, s) (c, .Kwhile b c k, s)

  | step_skip_seq : ∀ c k s,
      step (.SKIP, .Kseq c k, s) (c, k, s)

  | step_skip_while : ∀ b c k s,
      step (.SKIP, .Kwhile b c k, s) (.WHILE b c, k, s)

aeval

@[grind] def aeval (s : store) (a : aexp) : Int :=
  match a with
  | .CONST n => n
  | .VAR x => s x
  | .PLUS a1 a2 => aeval s a1 + aeval s a2
  | .MINUS a1 a2 => aeval s a1 - aeval s a2

plus

@[grind cases]
inductive plus (R : α → α → Prop) : α → α → Prop where
| plus_left : ∀ {a b c}, R a b → star R b c → plus R a c

grind_pattern plus.plus_left => star R b c, plus R a c

@[grind] theorem plus_star {a b} (h : plus R a b) : star R a b

@[grind] theorem star_trans {α} (R : α → α → Prop) (a b : α) (sab : star R a b) : ∀ c : α, star R b c → star R a c

theorem plus_right : star R a b -> R b c -> plus R a c

stack

def stack : Type := List Int

measure'

@[grind =] theorem codelen_cons :
  ∀ i c, codelen (i :: c) = codelen c + 1

@[grind =] theorem codelen_app :
  ∀ c1 c2, codelen (c1 ++ c2) = codelen c1 + codelen c2

@[grind =>] theorem instr_a : ∀ i c2 c1 pc,
  pc = codelen c1 ->
  instr_at (c1 ++ (i :: c2) ) pc = .some i

@[grind] theorem code_at_app_right :
  ∀ C pc C1 C2,
  code_at C pc (C1 ++ C2) ->
  code_at C (pc + codelen C1) C2

@[grind] theorem code_at_to_instr_at : code_at C pc (c1 ++ i :: c2) → instr_at C (pc + codelen c1) = .some i

theorem compile_aexp_correct (C : List instr) (s : store) (a : aexp) (pc : Int) (stk : stack) :
  code_at C pc (compile_aexp a) →
  transitions C (pc, stk, s) (pc + codelen (compile_aexp a), aeval s a :: stk, s)

theorem compile_bexp_correct (C : List instr) (s : store) (b : bexp) (d1 d0 : Int) (pc : Int) (stk : stack) (h : code_at C pc (compile_bexp b d1 d0))  :
   transitions C
       (pc, stk, s)
       (pc + codelen (compile_bexp b d1 d0) + (if beval s b then d1 else d0), stk, s)

theorem compile_cont_Kstop_inv (C : List instr) (pc : Int) (s : store) :
  compile_cont C .Kstop pc →
  ∃ pc',
  star (transition C) (pc, [], s) (pc', [], s)
  ∧ instr_at C pc' = .some .Ihalt

theorem compile_cont_Kseq_inv (C : List instr) (c : com) (k :cont) (pc : Int) (s : store) (H : compile_cont C (.Kseq c k) pc) :
  ∃ pc',
  star (transition C) (pc, [], s) (pc', [], s)
  ∧ code_at C pc' (compile_com c)
  ∧ compile_cont C k (pc' + codelen (compile_com c))

theorem compile_cont_Kwhile_inv (C : List instr) (b : bexp) (c : com) (k : cont) (pc : Int) (s : store) (H : compile_cont C (.Kwhile b c k) pc) :
  ∃ pc',
  plus (transition C) (pc, [], s) (pc', [], s)
  ∧ code_at C pc' (compile_com (.WHILE b c))
  ∧ compile_cont C k (pc' + codelen (compile_com (.WHILE b c)))

theorem match_config_skip (C : List instr) (k : cont) (s : store) (pc : Int) (H : compile_cont C k pc) :
 match_config C (.SKIP, k, s) (pc, [], s)

theorem simulation_step :
  ∀ C impconf1 impconf2 machconf1,
  step impconf1 impconf2 ->
  match_config C impconf1 machconf1 ->
  ∃ machconf2,
      (plus (transition C) machconf1 machconf2
       \/ (star (transition C) machconf1 machconf2
           /\ (measure' impconf2 < measure' impconf1)))
   /\ match_config C impconf2 machconf2

theorem simulation_steps :
  ∀ C impconf1 impconf2, star step impconf1 impconf2 ->
  ∀ machconf1, match_config C impconf1 machconf1 ->
  ∃ machconf2,
     star (transition C) machconf1 machconf2
  /\ match_config C impconf2 machconf2

theorem match_initial_configs :
  ∀ c s,
  match_config (compile_program c) (c, .Kstop, s) (0, [], s)

import LeroyCompilerVerificationCourse.Imp

@[grind] inductive instr : Type where
  | Iconst (n : Int)
  | Ivar (x : ident)
  | Isetvar (x : ident)
  | Iadd
  | Iopp
  | Ibranch (d : Int)
  | Ibeq (d1 : Int) (d0 : Int)
  | Ible (d1 : Int) (d0 : Int)
  | Ihalt
    deriving Repr

@[grind] def codelen (c : List instr) : Int := c.length

def stack : Type := List Int

def config : Type := Int × stack × store

@[grind] def instr_at (C : List instr) (pc : Int) : Option instr :=
  match C with
  | [] => .none
  | i :: C' => if pc = 0 then .some i else instr_at C' (pc - 1)

@[grind] inductive transition (C : List instr) : config → config → Prop where
  | trans_const : ∀ pc stk s n,
      instr_at C pc = .some (.Iconst n) →
      transition C (pc    , stk     , s)
                   (pc + 1, n :: stk, s)
  | trans_var : ∀ pc stk s x,
      instr_at C pc = .some (.Ivar x) ->
      transition C (pc    , stk       , s)
                   (pc + 1, s x :: stk, s)
  | trans_setvar : ∀ pc stk s x n,
      instr_at C pc = .some (.Isetvar x) ->
      transition C (pc    , n :: stk, s)
                   (pc + 1, stk     , update x n s)
  | trans_add : ∀ pc stk s n1 n2,
      instr_at C pc = .some (.Iadd) ->
      transition C (pc    , n2 :: n1 :: stk , s)
                   (pc + 1, (n1 + n2) :: stk, s)
  | trans_opp : ∀ pc stk s n,
      instr_at C pc = .some (.Iopp) ->
      transition C (pc    , n :: stk    , s)
                   (pc + 1, (- n) :: stk, s)
  | trans_branch : ∀ pc stk s d pc',
      instr_at C pc = .some (.Ibranch d) ->
      pc' = pc + 1 + d ->
      transition C (pc , stk, s)
                   (pc', stk, s)
  | trans_beq : ∀ pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = .some (.Ibeq d1 d0) ->
      pc' = pc + 1 + (if n1 = n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s)
  | trans_ble : ∀ pc stk s d1 d0 n1 n2 pc',
      instr_at C pc = .some (.Ible d1 d0) ->
      pc' = pc + 1 + (if n1 ≤ n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: stk, s)
                   (pc', stk            , s)

@[grind] def transitions (C : List instr) : config → config → Prop :=
  star (transition C)

def machine_terminates (C : List instr) (s_init : store) (s_final : store) : Prop :=
  ∃ pc, transitions C (0, [], s_init) (pc, [], s_final)
          ∧ instr_at C pc = .some .Ihalt

@[grind] def compile_aexp (a : aexp) : List instr :=
  match a with
  | .CONST n => .Iconst n :: []
  | .VAR x => .Ivar x :: []
  | .PLUS a1 a2  => (compile_aexp a1) ++ (compile_aexp a2) ++ (.Iadd :: [])
  | .MINUS a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ (.Iopp :: .Iadd :: [])

@[grind] def compile_bexp (b : bexp) (d1 : Int) (d0 : Int) : List instr :=
  match b with
  | .TRUE => if d1 = 0 then [] else .Ibranch d1 :: []
  | .FALSE => if d0 = 0 then [] else .Ibranch d0 :: []
  | .EQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ .Ibeq d1 d0 :: []
  | .LESSEQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ .Ible d1 d0 :: []
  | .NOT b1 => compile_bexp b1 d0 d1
  | .AND b1 b2 =>
      let code2 := compile_bexp b2 d1 d0
      let code1 := compile_bexp b1 0 (codelen code2 + d0)
      code1 ++ code2

@[grind] def compile_com (c : com) : List instr :=
  match c with
  | .SKIP =>
      []
  | .ASSIGN x a =>
      compile_aexp a ++ .Isetvar x :: []
  | .SEQ c1 c2 =>
      compile_com c1 ++ compile_com c2
  | .IFTHENELSE b ifso ifnot =>
      let code_ifso := compile_com ifso
      let code_ifnot := compile_com ifnot
      compile_bexp b 0 (codelen code_ifso + 1)
      ++ code_ifso
      ++ .Ibranch (codelen code_ifnot)
      :: code_ifnot
  | .WHILE b body =>
      let code_body := compile_com body
      let code_test := compile_bexp b 0 (codelen code_body + 1)
      code_test
      ++ code_body
      ++ .Ibranch (- (codelen code_test + codelen code_body + 1)) :: []

def compile_program (p : com) : List instr :=
  compile_com p ++ .Ihalt :: []

@[grind] inductive code_at : List instr → Int → List instr → Prop where
  | code_at_intro : ∀ C1 C2 C3 pc,
      pc = codelen C1 ->
      code_at (C1 ++ C2 ++ C3) pc C2

inductive compile_cont (C : List instr) : cont -> Int -> Prop where
  | ccont_stop : ∀ pc,
      instr_at C pc = .some .Ihalt ->
      compile_cont C .Kstop pc
  | ccont_seq : ∀ c k pc pc',
      code_at C pc (compile_com c) ->
      pc' = pc + codelen (compile_com c) ->
      compile_cont C k pc' ->
      compile_cont C (.Kseq c k) pc
  | ccont_while : ∀ b c k pc d pc' pc'',
      instr_at C pc = .some (.Ibranch d) ->
      pc' = pc + 1 + d ->
      code_at C pc' (compile_com (.WHILE b c)) ->
      pc'' = pc' + codelen (compile_com (.WHILE b c)) ->
      compile_cont C k pc'' ->
      compile_cont C (.Kwhile b c k) pc
  | ccont_branch : ∀ d k pc pc',
      instr_at C pc = .some (.Ibranch d) ->
      pc' = pc + 1 + d ->
      compile_cont C k pc' ->
      compile_cont C k pc

inductive match_config (C : List instr) : com × cont × store -> config -> Prop where
  | match_config_intro : ∀ c k st pc,
      code_at C pc (compile_com c) ->
      compile_cont C k (pc + codelen (compile_com c)) ->
      match_config C (c, k, st) (pc, [], st)

def com_size (c : com) : Nat :=
  match c with
  | .SKIP => 1
  | .ASSIGN _ _ => 1
  | (c1 ;; c2) => (com_size c1 + com_size c2 + 1)
  | .IFTHENELSE _ c1 c2 => (com_size c1 + com_size c2 + 1)
  | .WHILE _ c1 => (com_size c1 + 1)

def cont_size (k : cont) : Nat :=
  match k with
  | .Kstop => 0
  | .Kseq c k' => (com_size c + cont_size k')
  | .Kwhile _ _ k' => cont_size k'

def measure' (impconf : com × cont × store) : Nat :=
  match impconf with
  | (c, k, _) => (com_size c + cont_size k)

theorem compile_program_correct_terminating_2 :
  ∀ c s s',
  star step (c, .Kstop, s) (.SKIP, .Kstop, s') ->
  machine_terminates (compile_program c) s s' :=

:= by
    intro c s s' STAR
    generalize heq : compile_program c = C
    have ⟨ ms, A, B ⟩ := simulation_steps C (c, cont.Kstop, s) (com.SKIP, cont.Kstop, s') STAR (0, [], s) (by grind [match_initial_configs])
    cases B
    case match_config_intro pc w1 w2 =>
      have ⟨pc', D, E ⟩ := compile_cont_Kstop_inv C (pc + codelen (compile_com com.SKIP)) s' w2
      exists pc'
      constructor
      · apply star_trans
        · exact A
        · simp [compile_com, codelen] at D
          exact D
      · exact E