Register cases rules on lattice carriers for aesop automation

Tag the finite lattice carrier types with `@[aesop safe cases]`
(`AboveBelow`, `Sign`) so aesop performs the dominant proof step in this
framework -- case-splitting a lattice element -- automatically. Combined
with the existing `@[simp]` operation lemmas, this collapses the recurring
"case-split then reduce" proofs to a bare `aesop`:

  * AboveBelow's six lattice axioms drop their explicit `rcases`
  * Sign/Constant `plus_mono₂`/`minus_mono₂` become `by aesop`
  * Constant `plus_valid`/`minus_valid` shrink to a 2-line `rcases <;> simp_all`
  * `not_mk_lt_mk` is reexpressed via `le_cases`

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
2026-06-27 20:01:01 -05:00
parent 9e0702b5f5
commit 86bc33ee26
3 changed files with 23 additions and 57 deletions

View File

@@ -29,15 +29,13 @@ def minus : ConstLattice → ConstLattice → ConstLattice
lemma plus_mono₂ : Monotone₂ plus :=
AboveBelow.monotone₂_of_strict plus
(fun y => by cases y <;> rfl) (fun x => by cases x <;> rfl)
(fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
(fun x hx => by cases x <;> first | exact absurd rfl hx | rfl)
(fun y => by aesop) (fun x => by aesop)
(fun y hy => by aesop) (fun x hx => by aesop)
lemma minus_mono₂ : Monotone₂ minus :=
AboveBelow.monotone₂_of_strict minus
(fun y => by cases y <;> rfl) (fun x => by cases x <;> rfl)
(fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
(fun x hx => by cases x <;> first | exact absurd rfl hx | rfl)
(fun y => by aesop) (fun x => by aesop)
(fun y hy => by aesop) (fun x hx => by aesop)
def interpConst : ConstLattice Value Prop
| .bot, _ => False
@@ -96,36 +94,14 @@ def output : String :=
lemma plus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : }
(h₁ : g₁ (.int z₁)) (h₂ : g₂ (.int z₂)) :
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₂]
rcases g₁ with _ | _ | c₁ <;> rcases g₂ with _ | _ | c₂ <;>
simp_all [plus, constInterpretation, interpConst]
lemma minus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : }
(h₁ : g₁ (.int z₁)) (h₂ : g₂ (.int z₂)) :
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₂]
rcases g₁ with _ | _ | c₁ <;> rcases g₂ with _ | _ | c₂ <;>
simp_all [minus, constInterpretation, interpConst]
instance eval_valid : ValidExprEvaluator ConstLattice prog := by
constructor

View File

@@ -13,6 +13,8 @@ inductive Sign where
| zero
deriving DecidableEq
attribute [aesop safe cases] Sign
instance : Showable Sign :=
fun
| .plus => "+"
@@ -57,21 +59,13 @@ def minus : SignLattice → SignLattice → SignLattice
lemma plus_mono₂ : Monotone₂ plus :=
AboveBelow.monotone₂_of_strict plus
(fun y => by cases y <;> rfl)
(fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
(fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
(fun x hx => by
rcases x with _ | _ | s <;>
first | exact absurd rfl hx | rfl | (cases s <;> rfl))
(fun y => by aesop) (fun x => by aesop)
(fun y hy => by aesop) (fun x hx => by aesop)
lemma minus_mono₂ : Monotone₂ minus :=
AboveBelow.monotone₂_of_strict minus
(fun y => by cases y <;> rfl)
(fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
(fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
(fun x hx => by
rcases x with _ | _ | s <;>
first | exact absurd rfl hx | rfl | (cases s <;> rfl))
(fun y => by aesop) (fun x => by aesop)
(fun y hy => by aesop) (fun x hx => by aesop)
def interpSign : SignLattice Value Prop
| .bot, _ => False

View File

@@ -10,6 +10,8 @@ inductive AboveBelow (α : Type*) where
namespace AboveBelow
attribute [aesop safe cases] AboveBelow
instance {α : Type*} [ToString α] : ToString (AboveBelow α) where
toString
| bot => ""
@@ -49,22 +51,22 @@ instance : Min (AboveBelow α) where
(mk x mk y : AboveBelow α) = if x = y then mk x else bot := rfl
protected lemma sup_comm (a b : AboveBelow α) : a b = b a := by
rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> aesop
aesop
protected lemma sup_assoc (a b c : AboveBelow α) : a b c = a (b c) := by
rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> rcases c with _ | _ | z <;> aesop
aesop
protected lemma inf_comm (a b : AboveBelow α) : a b = b a := by
rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> aesop
aesop
protected lemma inf_assoc (a b c : AboveBelow α) : a b c = a (b c) := by
rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> rcases c with _ | _ | z <;> aesop
aesop
protected lemma sup_inf_self (a b : AboveBelow α) : a a b = a := by
rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> aesop
aesop
protected lemma inf_sup_self (a b : AboveBelow α) : a (a b) = a := by
rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> aesop
aesop
instance : Lattice (AboveBelow α) :=
Lattice.mk' AboveBelow.sup_comm AboveBelow.sup_assoc
@@ -189,13 +191,7 @@ def rank : AboveBelow α
lemma not_mk_lt_mk (x y : α) : ¬(mk x : AboveBelow α) < mk y := by
intro h
obtain hle, hne := lt_iff_le_and_ne.mp h
have hsup := le_iff.mp hle
rw [mk_sup_mk] at hsup
by_cases hxy : x = y
· rw [if_pos hxy] at hsup
exact hne hsup
· rw [if_neg hxy] at hsup
exact absurd hsup (by simp)
rcases le_cases hle with h | h | h <;> simp_all
lemma rank_strictMono : StrictMono (rank : AboveBelow α ) := by
intro a b hab