/-
Port of `Analysis/Constant.agda`.

Correspondence:
  showable, ≡-equiv, ≡-Decidable-ℤ ↦ (mathlib/derived instances)
  ConstLattice (AboveBelow ℤ)      ↦ ConstLattice
  AB.Plain (+ 0)                   ↦ constFixedHeight
  plus, minus                      ↦ plus, minus
  plus-Monoˡ/ʳ, minus-Monoˡ/ʳ (postulates in Agda!)
                                   ↦ plus_mono_left/right, minus_mono_left/right
                                     — now actually proved, via AboveBelow.le_cases
  plus-Mono₂, minus-Mono₂          ↦ plus_mono₂, minus_mono₂
  ⟦_⟧ᶜ                             ↦ interpConst
  ⟦⟧ᶜ-respects-≈ᶜ                  ↦ (trivial with `=`)
  ⟦⟧ᶜ-⊔ᶜ-∨, ⟦⟧ᶜ-⊓ᶜ-∧               ↦ interpConst_sup, interpConst_inf
  s₁≢s₂⇒¬s₁∧s₂                     ↦ interpConst_mk_disjoint
  latticeInterpretationᶜ           ↦ constInterpretation
  WithProg.eval, eval-Monoʳ        ↦ ConstAnalysis.eval, eval_mono
  ConstEval                        ↦ ConstAnalysis.exprEvaluator
  plus-valid, minus-valid          ↦ plus_valid, minus_valid
  eval-valid, ConstEvalValid       ↦ eval_valid
  output                           ↦ ConstAnalysis.output
  analyze-correct                  ↦ ConstAnalysis.analyze_correct
-/
import Spa.Analysis.Forward
import Spa.Analysis.Utils
import Spa.Showable

namespace Spa

abbrev ConstLattice : Type := AboveBelow ℤ

/-- Agda: `AB.Plain (+ 0)`'s `fixedHeight`. -/
def constFixedHeight : FixedHeight ConstLattice 2 :=
  AboveBelow.plainFixedHeight (0 : ℤ)

namespace ConstAnalysis

open AboveBelow in
/-- Agda: `plus`. -/
def plus : ConstLattice → ConstLattice → ConstLattice
  | bot, _ => bot
  | _, bot => bot
  | top, _ => top
  | _, top => top
  | mk z₁, mk z₂ => mk (z₁ + z₂)

open AboveBelow in
/-- Agda: `minus`. -/
def minus : ConstLattice → ConstLattice → ConstLattice
  | bot, _ => bot
  | _, bot => bot
  | top, _ => top
  | _, top => top
  | mk z₁, mk z₂ => mk (z₁ - z₂)

/-- Agda: `plus-Monoˡ` — a postulate there, a theorem here. -/
theorem plus_mono_left (s₂ : ConstLattice) : Monotone (plus · s₂) := by
  intro a b h
  rcases AboveBelow.le_cases h with rfl | rfl | rfl
  · rcases s₂ with _ | _ | y <;> rcases b with _ | _ | x <;>
      simp only [plus] <;>
      first
        | exact le_refl _
        | exact AboveBelow.le_top' _
        | exact AboveBelow.bot_le' _
  · rcases s₂ with _ | _ | y <;> rcases a with _ | _ | x <;>
      simp only [plus] <;>
      first
        | exact le_refl _
        | exact AboveBelow.le_top' _
  · exact le_refl _

/-- Agda: `plus-Monoʳ` — a postulate there, a theorem here. -/
theorem plus_mono_right (s₁ : ConstLattice) : Monotone (plus s₁) := by
  intro a b h
  rcases AboveBelow.le_cases h with rfl | rfl | rfl
  · rcases s₁ with _ | _ | x <;> rcases b with _ | _ | y <;>
      simp only [plus] <;>
      first
        | exact le_refl _
        | exact AboveBelow.le_top' _
        | exact AboveBelow.bot_le' _
  · rcases s₁ with _ | _ | x <;> rcases a with _ | _ | y <;>
      simp only [plus] <;>
      first
        | exact le_refl _
        | exact AboveBelow.le_top' _
  · exact le_refl _

/-- Agda: `plus-Mono₂`. -/
theorem plus_mono₂ : Monotone₂ plus :=
  ⟨plus_mono_left, plus_mono_right⟩

/-- Agda: `minus-Monoˡ` — a postulate there, a theorem here. -/
theorem minus_mono_left (s₂ : ConstLattice) : Monotone (minus · s₂) := by
  intro a b h
  rcases AboveBelow.le_cases h with rfl | rfl | rfl
  · rcases s₂ with _ | _ | y <;> rcases b with _ | _ | x <;>
      simp only [minus] <;>
      first
        | exact le_refl _
        | exact AboveBelow.le_top' _
        | exact AboveBelow.bot_le' _
  · rcases s₂ with _ | _ | y <;> rcases a with _ | _ | x <;>
      simp only [minus] <;>
      first
        | exact le_refl _
        | exact AboveBelow.le_top' _
  · exact le_refl _

/-- Agda: `minus-Monoʳ` — a postulate there, a theorem here. -/
theorem minus_mono_right (s₁ : ConstLattice) : Monotone (minus s₁) := by
  intro a b h
  rcases AboveBelow.le_cases h with rfl | rfl | rfl
  · rcases s₁ with _ | _ | x <;> rcases b with _ | _ | y <;>
      simp only [minus] <;>
      first
        | exact le_refl _
        | exact AboveBelow.le_top' _
        | exact AboveBelow.bot_le' _
  · rcases s₁ with _ | _ | x <;> rcases a with _ | _ | y <;>
      simp only [minus] <;>
      first
        | exact le_refl _
        | exact AboveBelow.le_top' _
  · exact le_refl _

/-- Agda: `minus-Mono₂`. -/
theorem minus_mono₂ : Monotone₂ minus :=
  ⟨minus_mono_left, minus_mono_right⟩

/-- Agda: `⟦_⟧ᶜ`. -/
def interpConst : ConstLattice → Value → Prop
  | .bot, _ => False
  | .top, _ => True
  | .mk z, v => v = .int z

/-- Agda: `s₁≢s₂⇒¬s₁∧s₂`. -/
theorem interpConst_mk_disjoint {z₁ z₂ : ℤ} (hne : z₁ ≠ z₂) {v : Value} :
    ¬(interpConst (.mk z₁) v ∧ interpConst (.mk z₂) v) := by
  rintro ⟨h₁, h₂⟩
  rw [h₁] at h₂
  injection h₂ with hz
  exact hne hz

/-- Agda: `⟦⟧ᶜ-⊔ᶜ-∨`. -/
theorem interpConst_sup {s₁ s₂ : ConstLattice} (v : Value)
    (h : interpConst s₁ v ∨ interpConst s₂ v) : interpConst (s₁ ⊔ s₂) v := by
  rcases s₁ with _ | _ | z₁
  · rcases h with h | h
    · exact h.elim
    · rw [AboveBelow.bot_sup]
      exact h
  · exact trivial
  · rcases s₂ with _ | _ | z₂
    · rcases h with h | h
      · rw [AboveBelow.sup_bot]
        exact h
      · exact h.elim
    · rw [AboveBelow.sup_top]
      exact trivial
    · by_cases hz : z₁ = z₂
      · subst hz
        rw [AboveBelow.mk_sup_mk, if_pos rfl]
        rcases h with h | h <;> exact h
      · rw [AboveBelow.mk_sup_mk, if_neg hz]
        exact trivial

/-- Agda: `⟦⟧ᶜ-⊓ᶜ-∧`. -/
theorem interpConst_inf {s₁ s₂ : ConstLattice} (v : Value)
    (h : interpConst s₁ v ∧ interpConst s₂ v) : interpConst (s₁ ⊓ s₂) v := by
  rcases s₁ with _ | _ | z₁
  · exact h.1
  · rw [AboveBelow.top_inf]
    exact h.2
  · rcases s₂ with _ | _ | z₂
    · exact h.2
    · rw [AboveBelow.inf_top]
      exact h.1
    · by_cases hz : z₁ = z₂
      · subst hz
        rw [AboveBelow.mk_inf_mk, if_pos rfl]
        exact h.1
      · exact absurd h (interpConst_mk_disjoint hz)

/-- Agda: `latticeInterpretationᶜ`. -/
def constInterpretation : LatticeInterpretation ConstLattice where
  interp := interpConst
  interp_sup := fun {l₁ l₂} v h => interpConst_sup (s₁ := l₁) (s₂ := l₂) v h
  interp_inf := fun {l₁ l₂} v h => interpConst_inf (s₁ := l₁) (s₂ := l₂) v h

variable (prog : Program)

/-- Agda: `WithProg.eval`. -/
def eval : Expr → VariableValues ConstLattice prog → ConstLattice
  | .add e₁ e₂, vs => plus (eval e₁ vs) (eval e₂ vs)
  | .sub e₁ e₂, vs => minus (eval e₁ vs) (eval e₂ vs)
  | .var k, vs =>
    if h : FiniteMap.MemKey k vs then (FiniteMap.locate h).1 else .top
  | .num n, _ => .mk n

/-- Agda: `WithProg.eval-Monoʳ`. -/
theorem eval_mono (e : Expr) : Monotone (eval prog e) := by
  induction e with
  | add e₁ e₂ ih₁ ih₂ =>
    intro vs₁ vs₂ h
    exact eval_combine₂ plus_mono₂ (ih₁ h) (ih₂ h)
  | sub e₁ e₂ ih₁ ih₂ =>
    intro vs₁ vs₂ h
    exact eval_combine₂ minus_mono₂ (ih₁ h) (ih₂ h)
  | var k =>
    intro vs₁ vs₂ h
    simp only [eval]
    by_cases hk : k ∈ prog.vars
    · rw [dif_pos (FiniteMap.memKey_iff.mpr hk),
          dif_pos (FiniteMap.memKey_iff.mpr hk)]
      exact FiniteMap.le_of_mem_mem prog.vars_nodup h
        (FiniteMap.locate _).2 (FiniteMap.locate _).2
    · rw [dif_neg (fun hm => hk (FiniteMap.memKey_iff.mp hm)),
          dif_neg (fun hm => hk (FiniteMap.memKey_iff.mp hm))]
  | num n =>
    intro vs₁ vs₂ _
    exact le_refl _

/-- Agda: the `ConstEval` instance. -/
def exprEvaluator : ExprEvaluator ConstLattice prog :=
  ⟨eval prog, eval_mono prog⟩

/-- Agda: `WithProg.result`/`output`. -/
def output : String :=
  show' (result constFixedHeight (exprEvaluator prog).toStmtEvaluator)

/-- Agda: `plus-valid`. -/
theorem plus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
    (h₁ : interpConst g₁ (.int z₁)) (h₂ : interpConst g₂ (.int z₂)) :
    interpConst (plus g₁ g₂) (.int (z₁ + z₂)) := by
  rcases g₁ with _ | _ | c₁
  · exact h₁.elim
  · rcases g₂ with _ | _ | c₂
    · exact h₂.elim
    · exact trivial
    · exact trivial
  · rcases g₂ with _ | _ | c₂
    · exact h₂.elim
    · exact trivial
    · injection h₁ with hz₁
      injection h₂ with hz₂
      show Value.int (z₁ + z₂) = Value.int (c₁ + c₂)
      rw [hz₁, hz₂]

/-- Agda: `minus-valid`. -/
theorem minus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
    (h₁ : interpConst g₁ (.int z₁)) (h₂ : interpConst g₂ (.int z₂)) :
    interpConst (minus g₁ g₂) (.int (z₁ - z₂)) := by
  rcases g₁ with _ | _ | c₁
  · exact h₁.elim
  · rcases g₂ with _ | _ | c₂
    · exact h₂.elim
    · exact trivial
    · exact trivial
  · rcases g₂ with _ | _ | c₂
    · exact h₂.elim
    · exact trivial
    · injection h₁ with hz₁
      injection h₂ with hz₂
      show Value.int (z₁ - z₂) = Value.int (c₁ - c₂)
      rw [hz₁, hz₂]

/-- Agda: `eval-valid` / `ConstEvalValid`. -/
theorem eval_valid :
    IsValidExprEvaluator (exprEvaluator prog) constInterpretation := by
  intro vs ρ e v hev
  induction hev with
  | num n =>
    intro _
    show interpConst (eval prog (.num n) vs) (.int n)
    rfl
  | var x v hxv =>
    intro hvs
    show interpConst (eval prog (.var x) vs) v
    simp only [eval]
    by_cases hk : FiniteMap.MemKey x vs
    · rw [dif_pos hk]
      exact hvs _ _ (FiniteMap.locate hk).2 _ hxv
    · rw [dif_neg hk]
      exact trivial
  | add e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
    intro hvs
    have h₁ : interpConst (eval prog e₁ vs) (.int z₁) := ih₁ hvs
    have h₂ : interpConst (eval prog e₂ vs) (.int z₂) := ih₂ hvs
    show interpConst (eval prog (.add e₁ e₂) vs) (.int (z₁ + z₂))
    exact plus_valid h₁ h₂
  | sub e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
    intro hvs
    have h₁ : interpConst (eval prog e₁ vs) (.int z₁) := ih₁ hvs
    have h₂ : interpConst (eval prog e₂ vs) (.int z₂) := ih₂ hvs
    show interpConst (eval prog (.sub e₁ e₂) vs) (.int (z₁ - z₂))
    exact minus_valid h₁ h₂

/-- Agda: `WithProg.analyze-correct`. -/
theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
    interpV constInterpretation
      (variablesAt prog.finalState
        (result constFixedHeight (exprEvaluator prog).toStmtEvaluator)) ρ :=
  Spa.analyze_correct constFixedHeight
    ((exprEvaluator prog).toStmtEvaluator_valid (eval_valid prog)) hrun

end ConstAnalysis

end Spa