refactor: denote functions in grind (#11071)
This PR ensures that the `denote` functions used to implement proof-by-reflection terms in `grind` are abbreviations. This change eliminates the need for the `withAbstractAtoms` gadget.
This commit is contained in:
Leonardo de Moura
GitHub
parent
a4e073f565
commit
52e37e0d55
13 changed files with 279 additions and 324 deletions
|
|
@ -4,7 +4,6 @@ Released under Apache 2.0 license as described in the file LICENSE.
|
|||
Authors: Leonardo de Moura
|
||||
-/
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Init.Data.Int.LemmasAux
|
||||
public import Init.Data.Int.Cooper
|
||||
|
|
@ -12,9 +11,7 @@ import all Init.Data.Int.Gcd
|
|||
public import Init.Data.AC
|
||||
import all Init.Data.AC
|
||||
import Init.LawfulBEqTactics
|
||||
|
||||
public section
|
||||
|
||||
namespace Int.Linear
|
||||
|
||||
/-! Helper definitions and theorems for constructing linear arithmetic proofs. -/
|
||||
|
|
@ -22,8 +19,7 @@ namespace Int.Linear
|
|||
abbrev Var := Nat
|
||||
abbrev Context := Lean.RArray Int
|
||||
|
||||
@[expose]
|
||||
def Var.denote (ctx : Context) (v : Var) : Int :=
|
||||
abbrev Var.denote (ctx : Context) (v : Var) : Int :=
|
||||
ctx.get v
|
||||
|
||||
inductive Expr where
|
||||
|
|
@ -36,8 +32,7 @@ inductive Expr where
|
|||
| mulR (a : Expr) (k : Int)
|
||||
deriving Inhabited, @[expose] BEq
|
||||
|
||||
@[expose]
|
||||
def Expr.denote (ctx : Context) : Expr → Int
|
||||
abbrev Expr.denote (ctx : Context) : Expr → Int
|
||||
| .add a b => denote ctx a + denote ctx b
|
||||
| .sub a b => denote ctx a - denote ctx b
|
||||
| .neg a => - denote ctx a
|
||||
|
|
@ -46,6 +41,9 @@ def Expr.denote (ctx : Context) : Expr → Int
|
|||
| .mulL k e => k * denote ctx e
|
||||
| .mulR e k => denote ctx e * k
|
||||
|
||||
set_option allowUnsafeReducibility true
|
||||
attribute [semireducible] Var.denote Expr.denote
|
||||
|
||||
inductive Poly where
|
||||
| num (k : Int)
|
||||
| add (k : Int) (v : Var) (p : Poly)
|
||||
|
|
@ -68,35 +66,36 @@ protected noncomputable def Poly.beq' (p₁ : Poly) : Poly → Bool :=
|
|||
intro _ _; subst k₁ v₁
|
||||
simp [← ih p₂, ← Bool.and'_eq_and]; rfl
|
||||
|
||||
@[expose]
|
||||
def Poly.denote (ctx : Context) (p : Poly) : Int :=
|
||||
abbrev Poly.denote (ctx : Context) (p : Poly) : Int :=
|
||||
match p with
|
||||
| .num k => k
|
||||
| .add k v p => k * v.denote ctx + denote ctx p
|
||||
|
||||
noncomputable abbrev Poly.denote'.go (ctx : Context) (p : Poly) : Int → Int :=
|
||||
Poly.rec
|
||||
(fun k r => Bool.rec
|
||||
(r + k)
|
||||
r
|
||||
(Int.beq' k 0))
|
||||
(fun k v _ ih r => Bool.rec
|
||||
(ih (r + k * v.denote ctx))
|
||||
(ih (r + v.denote ctx))
|
||||
(Int.beq' k 1))
|
||||
p
|
||||
|
||||
/--
|
||||
Similar to `Poly.denote`, but produces a denotation better for `simp +arith`.
|
||||
Remark: we used to convert `Poly` back into `Expr` to achieve that.
|
||||
-/
|
||||
@[expose] noncomputable def Poly.denote' (ctx : Context) (p : Poly) : Int :=
|
||||
noncomputable abbrev Poly.denote' (ctx : Context) (p : Poly) : Int :=
|
||||
Poly.rec (fun k => k)
|
||||
(fun k v p _ => Bool.rec
|
||||
(go p (k * v.denote ctx))
|
||||
(go p (v.denote ctx))
|
||||
(denote'.go ctx p (k * v.denote ctx))
|
||||
(denote'.go ctx p (v.denote ctx))
|
||||
(Int.beq' k 1))
|
||||
p
|
||||
where
|
||||
go (p : Poly) : Int → Int :=
|
||||
Poly.rec
|
||||
(fun k r => Bool.rec
|
||||
(r + k)
|
||||
r
|
||||
(Int.beq' k 0))
|
||||
(fun k v _ ih r => Bool.rec
|
||||
(ih (r + k * v.denote ctx))
|
||||
(ih (r + v.denote ctx))
|
||||
(Int.beq' k 1))
|
||||
p
|
||||
|
||||
attribute [semireducible] Poly.denote Poly.denote' Poly.denote'.go
|
||||
|
||||
@[simp] theorem Poly.denote'_go_eq_denote (ctx : Context) (p : Poly) (r : Int) : denote'.go ctx p r = p.denote ctx + r := by
|
||||
induction p generalizing r
|
||||
|
|
|
|||
|
|
@ -28,10 +28,10 @@ abbrev Context := Lean.RArray Nat
|
|||
/--
|
||||
When encoding polynomials. We use `fixedVar` for encoding numerals.
|
||||
The denotation of `fixedVar` is always `1`. -/
|
||||
def fixedVar := 100000000 -- Any big number should work here
|
||||
abbrev fixedVar := 100000000 -- Any big number should work here
|
||||
|
||||
def Var.denote (ctx : Context) (v : Var) : Nat :=
|
||||
bif v == fixedVar then 1 else ctx.get v
|
||||
noncomputable abbrev Var.denote (ctx : Context) (v : Var) : Nat :=
|
||||
Bool.rec (ctx.get v) 1 (Nat.beq v fixedVar)
|
||||
|
||||
inductive Expr where
|
||||
| num (v : Nat)
|
||||
|
|
@ -41,7 +41,7 @@ inductive Expr where
|
|||
| mulR (a : Expr) (k : Nat)
|
||||
deriving Inhabited, BEq
|
||||
|
||||
def Expr.denote (ctx : Context) : Expr → Nat
|
||||
noncomputable abbrev Expr.denote (ctx : Context) : Expr → Nat
|
||||
| .add a b => Nat.add (denote ctx a) (denote ctx b)
|
||||
| .num k => k
|
||||
| .var v => v.denote ctx
|
||||
|
|
@ -50,7 +50,7 @@ def Expr.denote (ctx : Context) : Expr → Nat
|
|||
|
||||
abbrev Poly := List (Nat × Var)
|
||||
|
||||
def Poly.denote (ctx : Context) (p : Poly) : Nat :=
|
||||
noncomputable abbrev Poly.denote (ctx : Context) (p : Poly) : Nat :=
|
||||
match p with
|
||||
| [] => 0
|
||||
| (k, v) :: p => Nat.add (Nat.mul k (v.denote ctx)) (denote ctx p)
|
||||
|
|
@ -113,9 +113,14 @@ def Poly.isNonZero (p : Poly) : Bool :=
|
|||
| [] => false
|
||||
| (k, v) :: p => bif v == fixedVar then k > 0 else isNonZero p
|
||||
|
||||
def Poly.denote_eq (ctx : Context) (mp : Poly × Poly) : Prop := mp.1.denote ctx = mp.2.denote ctx
|
||||
abbrev Poly.denote_eq (ctx : Context) (mp : Poly × Poly) : Prop :=
|
||||
mp.1.denote ctx = mp.2.denote ctx
|
||||
|
||||
def Poly.denote_le (ctx : Context) (mp : Poly × Poly) : Prop := mp.1.denote ctx ≤ mp.2.denote ctx
|
||||
abbrev Poly.denote_le (ctx : Context) (mp : Poly × Poly) : Prop :=
|
||||
mp.1.denote ctx ≤ mp.2.denote ctx
|
||||
|
||||
set_option allowUnsafeReducibility true
|
||||
attribute [semireducible] Poly.denote_eq Poly.denote_le
|
||||
|
||||
def Expr.toPoly (e : Expr) :=
|
||||
go 1 e []
|
||||
|
|
@ -146,7 +151,7 @@ structure ExprCnstr where
|
|||
lhs : Expr
|
||||
rhs : Expr
|
||||
|
||||
def PolyCnstr.denote (ctx : Context) (c : PolyCnstr) : Prop :=
|
||||
abbrev PolyCnstr.denote (ctx : Context) (c : PolyCnstr) : Prop :=
|
||||
bif c.eq then
|
||||
Poly.denote_eq ctx (c.lhs, c.rhs)
|
||||
else
|
||||
|
|
@ -168,7 +173,7 @@ def PolyCnstr.isValid (c : PolyCnstr) : Bool :=
|
|||
else
|
||||
c.lhs.isZero
|
||||
|
||||
def ExprCnstr.denote (ctx : Context) (c : ExprCnstr) : Prop :=
|
||||
abbrev ExprCnstr.denote (ctx : Context) (c : ExprCnstr) : Prop :=
|
||||
bif c.eq then
|
||||
c.lhs.denote ctx = c.rhs.denote ctx
|
||||
else
|
||||
|
|
|
|||
|
|
@ -4,12 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE.
|
|||
Authors: Leonardo de Moura
|
||||
-/
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Init.Data.List.BasicAux
|
||||
|
||||
public section
|
||||
|
||||
namespace Nat.SOM
|
||||
|
||||
open Linear (Var hugeFuel Context Var.denote)
|
||||
|
|
@ -21,7 +18,9 @@ inductive Expr where
|
|||
| mul (a b : Expr)
|
||||
deriving Inhabited
|
||||
|
||||
def Expr.denote (ctx : Context) : Expr → Nat
|
||||
set_option allowUnsafeReducibility true
|
||||
|
||||
noncomputable abbrev Expr.denote (ctx : Context) : Expr → Nat
|
||||
| num n => n
|
||||
| var v => v.denote ctx
|
||||
| add a b => Nat.add (a.denote ctx) (b.denote ctx)
|
||||
|
|
@ -29,10 +28,12 @@ def Expr.denote (ctx : Context) : Expr → Nat
|
|||
|
||||
abbrev Mon := List Var
|
||||
|
||||
def Mon.denote (ctx : Context) : Mon → Nat
|
||||
noncomputable abbrev Mon.denote (ctx : Context) : Mon → Nat
|
||||
| [] => 1
|
||||
| v::vs => Nat.mul (v.denote ctx) (denote ctx vs)
|
||||
|
||||
attribute [semireducible] Expr.denote Mon.denote
|
||||
|
||||
def Mon.mul (m₁ m₂ : Mon) : Mon :=
|
||||
go hugeFuel m₁ m₂
|
||||
where
|
||||
|
|
@ -53,10 +54,12 @@ where
|
|||
|
||||
abbrev Poly := List (Nat × Mon)
|
||||
|
||||
def Poly.denote (ctx : Context) : Poly → Nat
|
||||
noncomputable abbrev Poly.denote (ctx : Context) : Poly → Nat
|
||||
| [] => 0
|
||||
| (k, m) :: p => Nat.add (Nat.mul k (m.denote ctx)) (denote ctx p)
|
||||
|
||||
attribute [semireducible] Poly.denote
|
||||
|
||||
def Poly.add (p₁ p₂ : Poly) : Poly :=
|
||||
go hugeFuel p₁ p₂
|
||||
where
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ inductive RArray (α : Type u) : Type u where
|
|||
variable {α : Type u}
|
||||
|
||||
/-- The crucial operation, written with very little abstractional overhead -/
|
||||
noncomputable def RArray.get (a : RArray α) (n : Nat) : α :=
|
||||
noncomputable abbrev RArray.get (a : RArray α) (n : Nat) : α :=
|
||||
RArray.rec (fun x => x) (fun p _ _ l r => (Nat.ble p n).rec l r) a
|
||||
|
||||
private theorem RArray.get_eq_def (a : RArray α) (n : Nat) :
|
||||
|
|
|
|||
|
|
@ -39,10 +39,10 @@ inductive Expr where
|
|||
|
||||
abbrev Context (α : Type u) := RArray α
|
||||
|
||||
def Var.denote {α} (ctx : Context α) (v : Var) : α :=
|
||||
abbrev Var.denote {α} (ctx : Context α) (v : Var) : α :=
|
||||
ctx.get v
|
||||
|
||||
def Expr.denote {α} [IntModule α] (ctx : Context α) : Expr → α
|
||||
abbrev Expr.denote {α} [IntModule α] (ctx : Context α) : Expr → α
|
||||
| zero => 0
|
||||
| .var v => v.denote ctx
|
||||
| .add a b => denote ctx a + denote ctx b
|
||||
|
|
@ -56,25 +56,25 @@ inductive Poly where
|
|||
| add (k : Int) (v : Var) (p : Poly)
|
||||
deriving BEq, ReflBEq, LawfulBEq, Repr
|
||||
|
||||
def Poly.denote {α} [IntModule α] (ctx : Context α) (p : Poly) : α :=
|
||||
abbrev Poly.denote {α} [IntModule α] (ctx : Context α) (p : Poly) : α :=
|
||||
match p with
|
||||
| .nil => 0
|
||||
| .add k v p => k • v.denote ctx + denote ctx p
|
||||
|
||||
abbrev Poly.denote'.go {α} [IntModule α] (ctx : Context α) (r : α) (p : Poly) : α :=
|
||||
match p with
|
||||
| .nil => r
|
||||
| .add 1 v p => go ctx (r + v.denote ctx) p
|
||||
| .add k v p => go ctx (r + k • v.denote ctx) p
|
||||
|
||||
/--
|
||||
Similar to `Poly.denote`, but produces a denotation better for normalization.
|
||||
-/
|
||||
def Poly.denote' {α} [IntModule α] (ctx : Context α) (p : Poly) : α :=
|
||||
abbrev Poly.denote' {α} [IntModule α] (ctx : Context α) (p : Poly) : α :=
|
||||
match p with
|
||||
| .nil => 0
|
||||
| .add 1 v p => go (v.denote ctx) p
|
||||
| .add k v p => go (k • v.denote ctx) p
|
||||
where
|
||||
go (r : α) (p : Poly) : α :=
|
||||
match p with
|
||||
| .nil => r
|
||||
| .add 1 v p => go (r + v.denote ctx) p
|
||||
| .add k v p => go (r + k • v.denote ctx) p
|
||||
| .add 1 v p => denote'.go ctx (v.denote ctx) p
|
||||
| .add k v p => denote'.go ctx (k • v.denote ctx) p
|
||||
|
||||
-- Helper instance for `ac_rfl`
|
||||
local instance {α} [IntModule α] : Std.Associative (· + · : α → α → α) where
|
||||
|
|
@ -83,6 +83,8 @@ local instance {α} [IntModule α] : Std.Associative (· + · : α → α → α
|
|||
local instance {α} [IntModule α] : Std.Commutative (· + · : α → α → α) where
|
||||
comm := AddCommMonoid.add_comm
|
||||
|
||||
set_option allowUnsafeReducibility true in
|
||||
attribute [semireducible] Poly.denote' Poly.denote'.go in
|
||||
private theorem Poly.denote'_go_eq_denote {α} [IntModule α] (ctx : Context α) (p : Poly) (r : α) : denote'.go ctx r p = p.denote ctx + r := by
|
||||
induction r, p using denote'.go.induct ctx <;> simp [denote'.go, denote]
|
||||
next ih => rw [ih]; ac_rfl
|
||||
|
|
|
|||
|
|
@ -42,16 +42,18 @@ inductive Expr where
|
|||
|
||||
abbrev Context (α : Type u) := RArray α
|
||||
|
||||
def Var.denote {α} (ctx : Context α) (v : Var) : α :=
|
||||
set_option allowUnsafeReducibility true
|
||||
|
||||
abbrev Var.denote {α} (ctx : Context α) (v : Var) : α :=
|
||||
ctx.get v
|
||||
|
||||
noncomputable def denoteInt {α} [Ring α] (k : Int) : α :=
|
||||
noncomputable abbrev denoteInt {α} [Ring α] (k : Int) : α :=
|
||||
Bool.rec
|
||||
(OfNat.ofNat (α := α) k.natAbs)
|
||||
(- OfNat.ofNat (α := α) k.natAbs)
|
||||
(Int.blt' k 0)
|
||||
|
||||
noncomputable def Expr.denote {α} [Ring α] (ctx : Context α) (e : Expr) : α :=
|
||||
noncomputable abbrev Expr.denote {α} [Ring α] (ctx : Context α) (e : Expr) : α :=
|
||||
Expr.rec
|
||||
(fun k => denoteInt k)
|
||||
(fun k => NatCast.natCast (R := α) k)
|
||||
|
|
@ -64,6 +66,8 @@ noncomputable def Expr.denote {α} [Ring α] (ctx : Context α) (e : Expr) : α
|
|||
(fun _ k ih => ih ^ k)
|
||||
e
|
||||
|
||||
attribute [semireducible] Var.denote denoteInt Expr.denote
|
||||
|
||||
structure Power where
|
||||
x : Var
|
||||
k : Nat
|
||||
|
|
@ -78,13 +82,15 @@ protected noncomputable def Power.beq' (pw₁ pw₂ : Power) : Bool :=
|
|||
def Power.varLt (p₁ p₂ : Power) : Bool :=
|
||||
p₁.x.blt p₂.x
|
||||
|
||||
def Power.denote {α} [Semiring α] (ctx : Context α) : Power → α
|
||||
abbrev Power.denote {α} [Semiring α] (ctx : Context α) : Power → α
|
||||
| {x, k} =>
|
||||
match k with
|
||||
| 0 => 1
|
||||
| 1 => x.denote ctx
|
||||
| k => x.denote ctx ^ k
|
||||
|
||||
attribute [semireducible] Power.denote
|
||||
|
||||
inductive Mon where
|
||||
| unit
|
||||
| mult (p : Power) (m : Mon)
|
||||
|
|
@ -102,19 +108,21 @@ protected noncomputable def Mon.beq' (m₁ : Mon) : Mon → Bool :=
|
|||
simp [← ih m₂, ← Bool.and'_eq_and]
|
||||
rfl
|
||||
|
||||
def Mon.denote {α} [Semiring α] (ctx : Context α) : Mon → α
|
||||
abbrev Mon.denote {α} [Semiring α] (ctx : Context α) : Mon → α
|
||||
| unit => 1
|
||||
| .mult p m => p.denote ctx * denote ctx m
|
||||
|
||||
def Mon.denote' {α} [Semiring α] (ctx : Context α) (m : Mon) : α :=
|
||||
abbrev Mon.denote'.go [Semiring α] (ctx : Context α) (m : Mon) (acc : α) : α :=
|
||||
match m with
|
||||
| .unit => acc
|
||||
| .mult pw m => go ctx m (acc * (pw.denote ctx))
|
||||
|
||||
abbrev Mon.denote' {α} [Semiring α] (ctx : Context α) (m : Mon) : α :=
|
||||
match m with
|
||||
| .unit => 1
|
||||
| .mult pw m => go m (pw.denote ctx)
|
||||
where
|
||||
go (m : Mon) (acc : α) : α :=
|
||||
match m with
|
||||
| .unit => acc
|
||||
| .mult pw m => go m (acc * (pw.denote ctx))
|
||||
| .mult pw m => denote'.go ctx m (pw.denote ctx)
|
||||
|
||||
attribute [semireducible] Mon.denote Mon.denote' Mon.denote'.go
|
||||
|
||||
def Mon.ofVar (x : Var) : Mon :=
|
||||
.mult { x, k := 1 } .unit
|
||||
|
|
@ -328,27 +336,29 @@ protected noncomputable def Poly.beq' (p₁ : Poly) : Poly → Bool :=
|
|||
intro _ _; subst k₁ m₁
|
||||
simp [← ih p₂, ← Bool.and'_eq_and]; rfl
|
||||
|
||||
def Poly.denote [Ring α] (ctx : Context α) (p : Poly) : α :=
|
||||
abbrev Poly.denote [Ring α] (ctx : Context α) (p : Poly) : α :=
|
||||
match p with
|
||||
| .num k => Int.cast k
|
||||
| .add k m p => k • (m.denote ctx) + denote ctx p
|
||||
|
||||
def Poly.denote' [Ring α] (ctx : Context α) (p : Poly) : α :=
|
||||
match p with
|
||||
| .num k => Int.cast k
|
||||
| .add k m p => go p (denoteTerm k m)
|
||||
where
|
||||
denoteTerm (k : Int) (m : Mon) : α :=
|
||||
bif k == 1 then
|
||||
m.denote' ctx
|
||||
else
|
||||
k • m.denote' ctx
|
||||
abbrev denoteTerm [Ring α] (ctx : Context α) (k : Int) (m : Mon) : α :=
|
||||
bif k == 1 then
|
||||
m.denote' ctx
|
||||
else
|
||||
k • m.denote' ctx
|
||||
|
||||
go (p : Poly) (acc : α) : α :=
|
||||
abbrev Poly.denote'.go [Ring α] (ctx : Context α) (p : Poly) (acc : α) : α :=
|
||||
match p with
|
||||
| .num 0 => acc
|
||||
| .num k => acc + Int.cast k
|
||||
| .add k m p => go p (acc + denoteTerm k m)
|
||||
| .add k m p => go ctx p (acc + denoteTerm ctx k m)
|
||||
|
||||
abbrev Poly.denote' [Ring α] (ctx : Context α) (p : Poly) : α :=
|
||||
match p with
|
||||
| .num k => Int.cast k
|
||||
| .add k m p => denote'.go ctx p (denoteTerm ctx k m)
|
||||
|
||||
attribute [semireducible] Poly.denote Poly.denote' Poly.denote'.go denoteTerm
|
||||
|
||||
def Poly.ofMon (m : Mon) : Poly :=
|
||||
.add 1 m (.num 0)
|
||||
|
|
@ -995,8 +1005,8 @@ theorem Mon.eq_of_revlex {m₁ m₂ : Mon} : revlex m₁ m₂ = .eq → m₁ = m
|
|||
theorem Mon.eq_of_grevlex {m₁ m₂ : Mon} : grevlex m₁ m₂ = .eq → m₁ = m₂ := by
|
||||
simp [grevlex]; intro; apply eq_of_revlex
|
||||
|
||||
theorem Poly.denoteTerm_eq {α} [Ring α] (ctx : Context α) (k : Int) (m : Mon) : denote'.denoteTerm ctx k m = k * m.denote ctx := by
|
||||
simp [denote'.denoteTerm, Mon.denote'_eq_denote, cond_eq_ite, zsmul_eq_intCast_mul]; intro; subst k; rw [Ring.intCast_one, Semiring.one_mul]
|
||||
theorem Poly.denoteTerm_eq {α} [Ring α] (ctx : Context α) (k : Int) (m : Mon) : denoteTerm ctx k m = k * m.denote ctx := by
|
||||
simp [denoteTerm, Mon.denote'_eq_denote, cond_eq_ite, zsmul_eq_intCast_mul]; intro; subst k; rw [Ring.intCast_one, Semiring.one_mul]
|
||||
|
||||
theorem Poly.denote'_eq_denote {α} [Ring α] (ctx : Context α) (p : Poly) : p.denote' ctx = p.denote ctx := by
|
||||
cases p <;> simp [denote', denote, denoteTerm_eq, zsmul_eq_intCast_mul]
|
||||
|
|
|
|||
|
|
@ -396,41 +396,38 @@ private def norm (vars : PArray Expr) (lhs rhs lhs' rhs' : RingExpr) : NormResul
|
|||
def mkLeIffProof (leInst ltInst isPreorderInst orderedRingInst : Expr) (lhs rhs lhs' rhs' : RingExpr) : RingM Expr := do
|
||||
let ring ← getCommRing
|
||||
let { lhs, rhs, lhs', rhs', vars } := norm ring.vars lhs rhs lhs' rhs'
|
||||
withAbstractAtoms vars ring.type fun vars => do
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp6 (mkConst ``Grind.CommRing.le_norm_expr [ring.u]) ring.type ring.commRingInst leInst ltInst isPreorderInst orderedRingInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let leFn := mkApp2 (mkConst ``LE.le [ring.u]) ring.type leInst
|
||||
let le := mkApp2 leFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let le' := mkApp2 leFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq le le'
|
||||
return mkExpectedPropHint h expected
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp6 (mkConst ``Grind.CommRing.le_norm_expr [ring.u]) ring.type ring.commRingInst leInst ltInst isPreorderInst orderedRingInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let leFn := mkApp2 (mkConst ``LE.le [ring.u]) ring.type leInst
|
||||
let le := mkApp2 leFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let le' := mkApp2 leFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq le le'
|
||||
return mkExpectedPropHint h expected
|
||||
|
||||
def mkLtIffProof (leInst ltInst lawfulOrdLtInst isPreorderInst orderedRingInst : Expr) (lhs rhs lhs' rhs' : RingExpr) : RingM Expr := do
|
||||
let ring ← getCommRing
|
||||
let { lhs, rhs, lhs', rhs', vars } := norm ring.vars lhs rhs lhs' rhs'
|
||||
withAbstractAtoms vars ring.type fun vars => do
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp7 (mkConst ``Grind.CommRing.lt_norm_expr [ring.u]) ring.type ring.commRingInst leInst ltInst lawfulOrdLtInst isPreorderInst orderedRingInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let ltFn := mkApp2 (mkConst ``LT.lt [ring.u]) ring.type ltInst
|
||||
let lt := mkApp2 ltFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let lt' := mkApp2 ltFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq lt lt'
|
||||
return mkExpectedPropHint h expected
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp7 (mkConst ``Grind.CommRing.lt_norm_expr [ring.u]) ring.type ring.commRingInst leInst ltInst lawfulOrdLtInst isPreorderInst orderedRingInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let ltFn := mkApp2 (mkConst ``LT.lt [ring.u]) ring.type ltInst
|
||||
let lt := mkApp2 ltFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let lt' := mkApp2 ltFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq lt lt'
|
||||
return mkExpectedPropHint h expected
|
||||
|
||||
def mkEqIffProof (lhs rhs lhs' rhs' : RingExpr) : RingM Expr := do
|
||||
let ring ← getCommRing
|
||||
let { lhs, rhs, lhs', rhs', vars } := norm ring.vars lhs rhs lhs' rhs'
|
||||
withAbstractAtoms vars ring.type fun vars => do
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp2 (mkConst ``Grind.CommRing.eq_norm_expr [ring.u]) ring.type ring.commRingInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let eqFn := mkApp (mkConst ``Eq [Level.succ ring.u]) ring.type
|
||||
let eq := mkApp2 eqFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let eq' := mkApp2 eqFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq eq eq'
|
||||
return mkExpectedPropHint h expected
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp2 (mkConst ``Grind.CommRing.eq_norm_expr [ring.u]) ring.type ring.commRingInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let eqFn := mkApp (mkConst ``Eq [Level.succ ring.u]) ring.type
|
||||
let eq := mkApp2 eqFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let eq' := mkApp2 eqFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq eq eq'
|
||||
return mkExpectedPropHint h expected
|
||||
|
||||
/--
|
||||
Given `e` and `e'` s.t. `e.toPoly == e'.toPoly`, returns a proof that `e.denote ctx = e'.denote ctx`
|
||||
|
|
@ -438,52 +435,48 @@ Given `e` and `e'` s.t. `e.toPoly == e'.toPoly`, returns a proof that `e.denote
|
|||
def mkTermEqProof (e e' : RingExpr) : RingM Expr := do
|
||||
let ring ← getCommRing
|
||||
let { lhs, lhs', vars, .. } := norm ring.vars e (.num 0) e' (.num 0)
|
||||
withAbstractAtoms vars ring.type fun vars => do
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp2 (mkConst ``Grind.CommRing.Expr.eq_of_toPoly_eq [ring.u]) ring.type ring.commRingInst
|
||||
let h := mkApp4 h ctx (toExpr lhs) (toExpr lhs') eagerReflBoolTrue
|
||||
let eqFn := mkApp (mkConst ``Eq [Level.succ ring.u]) ring.type
|
||||
let expected := mkApp2 eqFn (← lhs.denoteExpr' vars) (← lhs'.denoteExpr' vars)
|
||||
return mkExpectedPropHint h expected
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp2 (mkConst ``Grind.CommRing.Expr.eq_of_toPoly_eq [ring.u]) ring.type ring.commRingInst
|
||||
let h := mkApp4 h ctx (toExpr lhs) (toExpr lhs') eagerReflBoolTrue
|
||||
let eqFn := mkApp (mkConst ``Eq [Level.succ ring.u]) ring.type
|
||||
let expected := mkApp2 eqFn (← lhs.denoteExpr' vars) (← lhs'.denoteExpr' vars)
|
||||
return mkExpectedPropHint h expected
|
||||
|
||||
def mkNonCommLeIffProof (leInst ltInst isPreorderInst orderedRingInst : Expr) (lhs rhs lhs' rhs' : RingExpr) : NonCommRingM Expr := do
|
||||
let ring ← getRing
|
||||
let { lhs, rhs, lhs', rhs', vars } := norm ring.vars lhs rhs lhs' rhs'
|
||||
withAbstractAtoms vars ring.type fun vars => do
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp6 (mkConst ``Grind.CommRing.le_norm_expr_nc [ring.u]) ring.type ring.ringInst leInst ltInst isPreorderInst orderedRingInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let leFn := mkApp2 (mkConst ``LE.le [ring.u]) ring.type leInst
|
||||
let le := mkApp2 leFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let le' := mkApp2 leFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq le le'
|
||||
return mkExpectedPropHint h expected
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp6 (mkConst ``Grind.CommRing.le_norm_expr_nc [ring.u]) ring.type ring.ringInst leInst ltInst isPreorderInst orderedRingInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let leFn := mkApp2 (mkConst ``LE.le [ring.u]) ring.type leInst
|
||||
let le := mkApp2 leFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let le' := mkApp2 leFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq le le'
|
||||
return mkExpectedPropHint h expected
|
||||
|
||||
def mkNonCommLtIffProof (leInst ltInst lawfulOrdLtInst isPreorderInst orderedRingInst : Expr) (lhs rhs lhs' rhs' : RingExpr) : NonCommRingM Expr := do
|
||||
let ring ← getRing
|
||||
let { lhs, rhs, lhs', rhs', vars } := norm ring.vars lhs rhs lhs' rhs'
|
||||
withAbstractAtoms vars ring.type fun vars => do
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp7 (mkConst ``Grind.CommRing.lt_norm_expr_nc [ring.u]) ring.type ring.ringInst leInst ltInst lawfulOrdLtInst isPreorderInst orderedRingInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let ltFn := mkApp2 (mkConst ``LT.lt [ring.u]) ring.type ltInst
|
||||
let lt := mkApp2 ltFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let lt' := mkApp2 ltFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq lt lt'
|
||||
return mkExpectedPropHint h expected
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp7 (mkConst ``Grind.CommRing.lt_norm_expr_nc [ring.u]) ring.type ring.ringInst leInst ltInst lawfulOrdLtInst isPreorderInst orderedRingInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let ltFn := mkApp2 (mkConst ``LT.lt [ring.u]) ring.type ltInst
|
||||
let lt := mkApp2 ltFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let lt' := mkApp2 ltFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq lt lt'
|
||||
return mkExpectedPropHint h expected
|
||||
|
||||
def mkNonCommEqIffProof (lhs rhs lhs' rhs' : RingExpr) : NonCommRingM Expr := do
|
||||
let ring ← getRing
|
||||
let { lhs, rhs, lhs', rhs', vars } := norm ring.vars lhs rhs lhs' rhs'
|
||||
withAbstractAtoms vars ring.type fun vars => do
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp2 (mkConst ``Grind.CommRing.eq_norm_expr_nc [ring.u]) ring.type ring.ringInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let eqFn := mkApp (mkConst ``Eq [Level.succ ring.u]) ring.type
|
||||
let eq := mkApp2 eqFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let eq' := mkApp2 eqFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq eq eq'
|
||||
return mkExpectedPropHint h expected
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp2 (mkConst ``Grind.CommRing.eq_norm_expr_nc [ring.u]) ring.type ring.ringInst
|
||||
let h := mkApp6 h ctx (toExpr lhs) (toExpr rhs) (toExpr lhs') (toExpr rhs') eagerReflBoolTrue
|
||||
let eqFn := mkApp (mkConst ``Eq [Level.succ ring.u]) ring.type
|
||||
let eq := mkApp2 eqFn (← lhs.denoteExpr' vars) (← rhs.denoteExpr' vars)
|
||||
let eq' := mkApp2 eqFn (← lhs'.denoteExpr' vars) (← rhs'.denoteExpr' vars)
|
||||
let expected := mkPropEq eq eq'
|
||||
return mkExpectedPropHint h expected
|
||||
|
||||
/--
|
||||
Given `e` and `e'` s.t. `e.toPoly_nc == e'.toPoly_nc`, returns a proof that `e.denote ctx = e'.denote ctx`
|
||||
|
|
@ -491,12 +484,11 @@ Given `e` and `e'` s.t. `e.toPoly_nc == e'.toPoly_nc`, returns a proof that `e.d
|
|||
def mkNonCommTermEqProof (e e' : RingExpr) : NonCommRingM Expr := do
|
||||
let ring ← getRing
|
||||
let { lhs, lhs', vars, .. } := norm ring.vars e (.num 0) e' (.num 0)
|
||||
withAbstractAtoms vars ring.type fun vars => do
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp2 (mkConst ``Grind.CommRing.Expr.eq_of_toPoly_nc_eq [ring.u]) ring.type ring.ringInst
|
||||
let h := mkApp4 h ctx (toExpr lhs) (toExpr lhs') eagerReflBoolTrue
|
||||
let eqFn := mkApp (mkConst ``Eq [Level.succ ring.u]) ring.type
|
||||
let expected := mkApp2 eqFn (← lhs.denoteExpr' vars) (← lhs'.denoteExpr' vars)
|
||||
return mkExpectedPropHint h expected
|
||||
let ctx ← toContextExpr vars
|
||||
let h := mkApp2 (mkConst ``Grind.CommRing.Expr.eq_of_toPoly_nc_eq [ring.u]) ring.type ring.ringInst
|
||||
let h := mkApp4 h ctx (toExpr lhs) (toExpr lhs') eagerReflBoolTrue
|
||||
let eqFn := mkApp (mkConst ``Eq [Level.succ ring.u]) ring.type
|
||||
let expected := mkApp2 eqFn (← lhs.denoteExpr' vars) (← lhs'.denoteExpr' vars)
|
||||
return mkExpectedPropHint h expected
|
||||
|
||||
end Lean.Meta.Grind.Arith.CommRing
|
||||
|
|
|
|||
|
|
@ -10,27 +10,6 @@ public import Lean.Meta.SynthInstance
|
|||
public import Init.Data.Rat.Basic
|
||||
public section
|
||||
namespace Lean.Meta.Grind.Arith
|
||||
/--
|
||||
To prevent the kernel from accidentally reducing the atoms in the equation while typechecking,
|
||||
we abstract over them.
|
||||
-/
|
||||
def withAbstractAtoms [Monad m] [MonadControlT MetaM m] [MonadLiftT CoreM m] [MonadLiftT MetaM m]
|
||||
(atoms : Array Expr) (type : Expr) (k : Array Expr → m Expr) : m Expr := do
|
||||
let rec go (i : Nat) (atoms' : Array Expr) (xs : Array Expr) (args : Array Expr) : m Expr := do
|
||||
if h : i < atoms.size then
|
||||
let atom := atoms[i]
|
||||
if atom.isFVar then
|
||||
go (i+1) (atoms'.push atom) xs args
|
||||
else
|
||||
withLocalDeclD (← mkFreshUserName `x) type fun x =>
|
||||
go (i+1) (atoms'.push x) (xs.push x) (args.push atom)
|
||||
else
|
||||
let p ← k atoms'
|
||||
if xs.isEmpty then
|
||||
return p
|
||||
else
|
||||
return mkAppN (← mkLambdaFVars xs p) args
|
||||
go 0 #[] #[] #[]
|
||||
|
||||
/-- Returns `true` if `e` is a numeral and has type `Nat`. -/
|
||||
def isNatNum (e : Expr) : Bool := Id.run do
|
||||
|
|
|
|||
|
|
@ -4,7 +4,6 @@ Released under Apache 2.0 license as described in the file LICENSE.
|
|||
Authors: Leonardo de Moura
|
||||
-/
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Lean.Meta.Tactic.Simp.Arith.Int.Basic
|
||||
public import Lean.Meta.Tactic.Simp.Arith.Int.Simp
|
||||
|
|
|
|||
|
|
@ -4,11 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE.
|
|||
Authors: Leonardo de Moura
|
||||
-/
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Lean.Meta.Tactic.Simp.Arith.Util
|
||||
public import Lean.Meta.Tactic.Simp.Arith.Int.Basic
|
||||
|
||||
public section
|
||||
|
||||
def Int.Linear.Poly.gcdAll : Poly → Nat
|
||||
|
|
@ -35,77 +33,75 @@ namespace Lean.Meta.Simp.Arith.Int
|
|||
|
||||
def simpEq? (e : Expr) : MetaM (Option (Expr × Expr)) := do
|
||||
let some (a, b, atoms) ← eqCnstr? e | return none
|
||||
withAbstractAtoms atoms ``Int fun atoms => do
|
||||
let e := mkIntEq (← a.denoteExpr (atoms[·]!)) (← b.denoteExpr (atoms[·]!))
|
||||
let p := a.sub b |>.norm
|
||||
if p.isUnsatEq then
|
||||
let r := mkConst ``False
|
||||
let h := mkApp4 (mkConst ``Int.Linear.eq_eq_false) (← toContextExpr atoms) (toExpr a) (toExpr b) eagerReflBoolTrue
|
||||
let e := mkIntEq (← a.denoteExpr (atoms[·]!)) (← b.denoteExpr (atoms[·]!))
|
||||
let p := a.sub b |>.norm
|
||||
if p.isUnsatEq then
|
||||
let r := mkConst ``False
|
||||
let h := mkApp4 (mkConst ``Int.Linear.eq_eq_false) (← toContextExpr atoms) (toExpr a) (toExpr b) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
else if p.isValidEq then
|
||||
let r := mkConst ``True
|
||||
let h := mkApp4 (mkConst ``Int.Linear.eq_eq_true) (← toContextExpr atoms) (toExpr a) (toExpr b) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
else if p.toExpr == a && b == .num 0 then
|
||||
return none
|
||||
else match p with
|
||||
| .add 1 x (.add (-1) y (.num 0)) =>
|
||||
let r := mkIntEq atoms[x]! atoms[y]!
|
||||
let h := mkApp6 (mkConst ``Int.Linear.norm_eq_var) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr x) (toExpr y) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
else if p.isValidEq then
|
||||
let r := mkConst ``True
|
||||
let h := mkApp4 (mkConst ``Int.Linear.eq_eq_true) (← toContextExpr atoms) (toExpr a) (toExpr b) eagerReflBoolTrue
|
||||
| .add 1 x (.num k) =>
|
||||
let r := mkIntEq atoms[x]! (toExpr (-k))
|
||||
let h := mkApp6 (mkConst ``Int.Linear.norm_eq_var_const) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr x) (toExpr (-k)) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
else if p.toExpr == a && b == .num 0 then
|
||||
return none
|
||||
else match p with
|
||||
| .add 1 x (.add (-1) y (.num 0)) =>
|
||||
let r := mkIntEq atoms[x]! atoms[y]!
|
||||
let h := mkApp6 (mkConst ``Int.Linear.norm_eq_var) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr x) (toExpr y) eagerReflBoolTrue
|
||||
| _ =>
|
||||
let k := p.gcdCoeffs'
|
||||
if k == 1 then
|
||||
let r := mkIntEq (← p.denoteExpr (atoms[·]!)) (mkIntLit 0)
|
||||
let h := mkApp5 (mkConst ``Int.Linear.norm_eq) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr p) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
| .add 1 x (.num k) =>
|
||||
let r := mkIntEq atoms[x]! (toExpr (-k))
|
||||
let h := mkApp6 (mkConst ``Int.Linear.norm_eq_var_const) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr x) (toExpr (-k)) eagerReflBoolTrue
|
||||
else if p.getConst % k == 0 then
|
||||
let p := p.div k
|
||||
let r := mkIntEq (← p.denoteExpr (atoms[·]!)) (mkIntLit 0)
|
||||
let h := mkApp6 (mkConst ``Int.Linear.norm_eq_coeff) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr p) (toExpr (Int.ofNat k)) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
else
|
||||
let r := mkConst ``False
|
||||
let h := mkApp5 (mkConst ``Int.Linear.eq_eq_false_of_divCoeff) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr (Int.ofNat k)) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
| _ =>
|
||||
let k := p.gcdCoeffs'
|
||||
if k == 1 then
|
||||
let r := mkIntEq (← p.denoteExpr (atoms[·]!)) (mkIntLit 0)
|
||||
let h := mkApp5 (mkConst ``Int.Linear.norm_eq) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr p) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
else if p.getConst % k == 0 then
|
||||
let p := p.div k
|
||||
let r := mkIntEq (← p.denoteExpr (atoms[·]!)) (mkIntLit 0)
|
||||
let h := mkApp6 (mkConst ``Int.Linear.norm_eq_coeff) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr p) (toExpr (Int.ofNat k)) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
else
|
||||
let r := mkConst ``False
|
||||
let h := mkApp5 (mkConst ``Int.Linear.eq_eq_false_of_divCoeff) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr (Int.ofNat k)) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
|
||||
|
||||
def simpLe? (e : Expr) (checkIfModified : Bool) : MetaM (Option (Expr × Expr)) := do
|
||||
-- If `e` is not already a `≤`, then we should not check whether it has changed.
|
||||
let checkIfModified := e.isAppOf ``LE.le && checkIfModified
|
||||
let some (a, b, atoms) ← leCnstr? e | return none
|
||||
withAbstractAtoms atoms ``Int fun atoms => do
|
||||
let e := mkIntLE (← a.denoteExpr (atoms[·]!)) (← b.denoteExpr (atoms[·]!))
|
||||
let p := a.sub b |>.norm
|
||||
if p.isUnsatLe then
|
||||
let r := mkConst ``False
|
||||
let h := mkApp4 (mkConst ``Int.Linear.le_eq_false) (← toContextExpr atoms) (toExpr a) (toExpr b) eagerReflBoolTrue
|
||||
let e := mkIntLE (← a.denoteExpr (atoms[·]!)) (← b.denoteExpr (atoms[·]!))
|
||||
let p := a.sub b |>.norm
|
||||
if p.isUnsatLe then
|
||||
let r := mkConst ``False
|
||||
let h := mkApp4 (mkConst ``Int.Linear.le_eq_false) (← toContextExpr atoms) (toExpr a) (toExpr b) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
else if p.isValidLe then
|
||||
let r := mkConst ``True
|
||||
let h := mkApp4 (mkConst ``Int.Linear.le_eq_true) (← toContextExpr atoms) (toExpr a) (toExpr b) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
else if checkIfModified && p.toExpr == a && b == .num 0 then
|
||||
return none
|
||||
else
|
||||
let k := p.gcdCoeffs'
|
||||
if k == 1 then
|
||||
let r := mkIntLE (← p.denoteExpr (atoms[·]!)) (mkIntLit 0)
|
||||
let h := mkApp5 (mkConst ``Int.Linear.norm_le) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr p) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
else if p.isValidLe then
|
||||
let r := mkConst ``True
|
||||
let h := mkApp4 (mkConst ``Int.Linear.le_eq_true) (← toContextExpr atoms) (toExpr a) (toExpr b) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
else if checkIfModified && p.toExpr == a && b == .num 0 then
|
||||
return none
|
||||
else
|
||||
let k := p.gcdCoeffs'
|
||||
if k == 1 then
|
||||
let r := mkIntLE (← p.denoteExpr (atoms[·]!)) (mkIntLit 0)
|
||||
let h := mkApp5 (mkConst ``Int.Linear.norm_le) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr p) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
let tight := p.getConst % k != 0
|
||||
let p := p.div k
|
||||
let r := mkIntLE (← p.denoteExpr (atoms[·]!)) (mkIntLit 0)
|
||||
let h ← if tight then
|
||||
pure <| mkApp6 (mkConst ``Int.Linear.norm_le_coeff_tight) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr p) (toExpr (Int.ofNat k)) eagerReflBoolTrue
|
||||
else
|
||||
let tight := p.getConst % k != 0
|
||||
let p := p.div k
|
||||
let r := mkIntLE (← p.denoteExpr (atoms[·]!)) (mkIntLit 0)
|
||||
let h ← if tight then
|
||||
pure <| mkApp6 (mkConst ``Int.Linear.norm_le_coeff_tight) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr p) (toExpr (Int.ofNat k)) eagerReflBoolTrue
|
||||
else
|
||||
pure <| mkApp6 (mkConst ``Int.Linear.norm_le_coeff) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr p) (toExpr (Int.ofNat k)) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
pure <| mkApp6 (mkConst ``Int.Linear.norm_le_coeff) (← toContextExpr atoms) (toExpr a) (toExpr b) (toExpr p) (toExpr (Int.ofNat k)) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint h (mkPropEq e r))
|
||||
|
||||
def simpRel? (e : Expr) : MetaM (Option (Expr × Expr)) := do
|
||||
if let some arg := e.not? then
|
||||
|
|
@ -139,37 +135,35 @@ def simpRel? (e : Expr) : MetaM (Option (Expr × Expr)) := do
|
|||
def simpDvd? (e : Expr) : MetaM (Option (Expr × Expr)) := do
|
||||
let some (d, e, atoms) ← dvdCnstr? e | return none
|
||||
if d == 0 then return none
|
||||
withAbstractAtoms atoms ``Int fun atoms => do
|
||||
let lhs := mkIntDvd (toExpr d) (← e.denoteExpr (atoms[·]!))
|
||||
let p := e.norm
|
||||
let g := p.gcdCoeffs d
|
||||
if p.getConst % g == 0 then
|
||||
let p := p.div g
|
||||
let d' := d / g
|
||||
if e == p.toExpr then
|
||||
return none
|
||||
let rhs := mkIntDvd (toExpr d') (← p.denoteExpr (atoms[·]!))
|
||||
let h ← if g == 1 then
|
||||
pure <| mkApp5 (mkConst ``Int.Linear.norm_dvd) (← toContextExpr atoms) (toExpr d) (toExpr e) (toExpr p) eagerReflBoolTrue
|
||||
else
|
||||
pure <| mkApp7 (mkConst ``Int.Linear.norm_dvd_gcd) (← toContextExpr atoms) (toExpr d) (toExpr e) (toExpr d') (toExpr p) (toExpr g) eagerReflBoolTrue
|
||||
return some (rhs, mkExpectedPropHint h (mkPropEq lhs rhs))
|
||||
let lhs := mkIntDvd (toExpr d) (← e.denoteExpr (atoms[·]!))
|
||||
let p := e.norm
|
||||
let g := p.gcdCoeffs d
|
||||
if p.getConst % g == 0 then
|
||||
let p := p.div g
|
||||
let d' := d / g
|
||||
if e == p.toExpr then
|
||||
return none
|
||||
let rhs := mkIntDvd (toExpr d') (← p.denoteExpr (atoms[·]!))
|
||||
let h ← if g == 1 then
|
||||
pure <| mkApp5 (mkConst ``Int.Linear.norm_dvd) (← toContextExpr atoms) (toExpr d) (toExpr e) (toExpr p) eagerReflBoolTrue
|
||||
else
|
||||
let rhs := mkConst ``False
|
||||
let h := mkApp4 (mkConst ``Int.Linear.dvd_eq_false) (← toContextExpr atoms) (toExpr d) (toExpr e) eagerReflBoolTrue
|
||||
return some (rhs, mkExpectedPropHint h (mkPropEq lhs rhs))
|
||||
pure <| mkApp7 (mkConst ``Int.Linear.norm_dvd_gcd) (← toContextExpr atoms) (toExpr d) (toExpr e) (toExpr d') (toExpr p) (toExpr g) eagerReflBoolTrue
|
||||
return some (rhs, mkExpectedPropHint h (mkPropEq lhs rhs))
|
||||
else
|
||||
let rhs := mkConst ``False
|
||||
let h := mkApp4 (mkConst ``Int.Linear.dvd_eq_false) (← toContextExpr atoms) (toExpr d) (toExpr e) eagerReflBoolTrue
|
||||
return some (rhs, mkExpectedPropHint h (mkPropEq lhs rhs))
|
||||
|
||||
def simpExpr? (lhs : Expr) : MetaM (Option (Expr × Expr)) := do
|
||||
let (e, ctx) ← toLinearExpr lhs
|
||||
withAbstractAtoms ctx ``Int fun ctx => do
|
||||
let p := e.norm
|
||||
let e' := p.toExpr
|
||||
if e != e' then
|
||||
let h := mkApp4 (mkConst ``Int.Linear.Expr.eq_of_norm_eq) (← toContextExpr ctx) (toExpr e) (toExpr p) eagerReflBoolTrue
|
||||
let lhs ← e.denoteExpr (ctx[·]!)
|
||||
let rhs ← p.denoteExpr (ctx[·]!)
|
||||
return some (rhs, mkExpectedPropHint h (mkIntEq lhs rhs))
|
||||
else
|
||||
return none
|
||||
let p := e.norm
|
||||
let e' := p.toExpr
|
||||
if e != e' then
|
||||
let h := mkApp4 (mkConst ``Int.Linear.Expr.eq_of_norm_eq) (← toContextExpr ctx) (toExpr e) (toExpr p) eagerReflBoolTrue
|
||||
let lhs ← e.denoteExpr (ctx[·]!)
|
||||
let rhs ← p.denoteExpr (ctx[·]!)
|
||||
return some (rhs, mkExpectedPropHint h (mkIntEq lhs rhs))
|
||||
else
|
||||
return none
|
||||
|
||||
end Lean.Meta.Simp.Arith.Int
|
||||
|
|
|
|||
|
|
@ -14,26 +14,28 @@ namespace Lean.Meta.Simp.Arith.Nat
|
|||
def simpCnstrPos? (e : Expr) : MetaM (Option (Expr × Expr)) := do
|
||||
let some (c, atoms) ← toLinearCnstr? e
|
||||
| return none
|
||||
withAbstractAtoms atoms ``Nat fun atoms => do
|
||||
let lhs ← c.toArith atoms
|
||||
let c₁ := c.toPoly
|
||||
let c₂ := c₁.norm
|
||||
if c₂.isUnsat then
|
||||
let r := mkConst ``False
|
||||
let p := mkApp3 (mkConst ``Nat.Linear.ExprCnstr.eq_false_of_isUnsat) (← toContextExpr atoms) (toExpr c) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint p (mkPropEq lhs r))
|
||||
else if c₂.isValid then
|
||||
let r := mkConst ``True
|
||||
let p := mkApp3 (mkConst ``Nat.Linear.ExprCnstr.eq_true_of_isValid) (← toContextExpr atoms) (toExpr c) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint p (mkPropEq lhs r))
|
||||
let lhs ← c.toArith atoms
|
||||
let c₁ := c.toPoly
|
||||
let c₂ := c₁.norm
|
||||
if c₂.isUnsat then
|
||||
let r := mkConst ``False
|
||||
let p := mkApp3 (mkConst ``Nat.Linear.ExprCnstr.eq_false_of_isUnsat) (← toContextExpr atoms) (toExpr c) eagerReflBoolTrue
|
||||
let h := mkExpectedPropHint p (mkPropEq lhs r)
|
||||
return some (r, h)
|
||||
else if c₂.isValid then
|
||||
let r := mkConst ``True
|
||||
let p := mkApp3 (mkConst ``Nat.Linear.ExprCnstr.eq_true_of_isValid) (← toContextExpr atoms) (toExpr c) eagerReflBoolTrue
|
||||
let h := mkExpectedPropHint p (mkPropEq lhs r)
|
||||
return some (r, h)
|
||||
else
|
||||
let c₂ : LinearCnstr := c₂.toExpr
|
||||
let r ← c₂.toArith atoms
|
||||
if r != lhs then
|
||||
let p := mkApp4 (mkConst ``Nat.Linear.ExprCnstr.eq_of_toNormPoly_eq) (← toContextExpr atoms) (toExpr c) (toExpr c₂) eagerReflBoolTrue
|
||||
let h := mkExpectedPropHint p (mkPropEq lhs r)
|
||||
return some (r, h)
|
||||
else
|
||||
let c₂ : LinearCnstr := c₂.toExpr
|
||||
let r ← c₂.toArith atoms
|
||||
if r != lhs then
|
||||
let p := mkApp4 (mkConst ``Nat.Linear.ExprCnstr.eq_of_toNormPoly_eq) (← toContextExpr atoms) (toExpr c) (toExpr c₂) eagerReflBoolTrue
|
||||
return some (r, mkExpectedPropHint p (mkPropEq lhs r))
|
||||
else
|
||||
return none
|
||||
return none
|
||||
|
||||
def simpCnstr? (e : Expr) : MetaM (Option (Expr × Expr)) := do
|
||||
if let some arg := e.not? then
|
||||
|
|
@ -66,15 +68,15 @@ def simpCnstr? (e : Expr) : MetaM (Option (Expr × Expr)) := do
|
|||
|
||||
def simpExpr? (input : Expr) : MetaM (Option (Expr × Expr)) := do
|
||||
let (e, ctx) ← toLinearExpr input
|
||||
withAbstractAtoms ctx ``Nat fun ctx => do
|
||||
let p := e.toPoly
|
||||
let p' := p.norm
|
||||
let e' : LinearExpr := p'.toExpr
|
||||
if e' == e then
|
||||
return none
|
||||
let p := mkApp4 (mkConst ``Nat.Linear.Expr.eq_of_toNormPoly_eq) (← toContextExpr ctx) (toExpr e) (toExpr e') eagerReflBoolTrue
|
||||
let l ← e.toArith ctx
|
||||
let r ← e'.toArith ctx
|
||||
return some (r, mkExpectedPropHint p (mkNatEq l r))
|
||||
let p := e.toPoly
|
||||
let p' := p.norm
|
||||
let e' : LinearExpr := p'.toExpr
|
||||
if e' == e then
|
||||
return none
|
||||
let p := mkApp4 (mkConst ``Nat.Linear.Expr.eq_of_toNormPoly_eq) (← toContextExpr ctx) (toExpr e) (toExpr e') eagerReflBoolTrue
|
||||
let l ← e.toArith ctx
|
||||
let r ← e'.toArith ctx
|
||||
let h := mkExpectedPropHint p (mkNatEq l r)
|
||||
return some (r, h)
|
||||
|
||||
end Lean.Meta.Simp.Arith.Nat
|
||||
|
|
|
|||
|
|
@ -4,37 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE.
|
|||
Authors: Leonardo de Moura
|
||||
-/
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Lean.Meta.Basic
|
||||
|
||||
public section
|
||||
|
||||
namespace Lean.Meta.Simp.Arith
|
||||
/-
|
||||
To prevent the kernel from accidentally reducing the atoms in the equation while typechecking,
|
||||
we abstract over them.
|
||||
-/
|
||||
def withAbstractAtoms (atoms : Array Expr) (type : Name) (k : Array Expr → MetaM (Option (Expr × Expr))) :
|
||||
MetaM (Option (Expr × Expr)) := do
|
||||
let type := mkConst type
|
||||
let rec go (i : Nat) (atoms' : Array Expr) (xs : Array Expr) (args : Array Expr) : MetaM (Option (Expr × Expr)) := do
|
||||
if h : i < atoms.size then
|
||||
let atom := atoms[i]
|
||||
if atom.isFVar then
|
||||
go (i+1) (atoms'.push atom) xs args
|
||||
else
|
||||
withLocalDeclD (← mkFreshUserName `x) type fun x =>
|
||||
go (i+1) (atoms'.push x) (xs.push x) (args.push atom)
|
||||
else
|
||||
if xs.isEmpty then
|
||||
k atoms'
|
||||
else
|
||||
let some (r, p) ← k atoms' | return none
|
||||
let r := (← mkLambdaFVars xs r).beta args
|
||||
let p := mkAppN (← mkLambdaFVars xs p) args
|
||||
return some (r, p)
|
||||
go 0 #[] #[] #[]
|
||||
|
||||
private def isSupportedType (type : Expr) : Bool :=
|
||||
match_expr type with
|
||||
|
|
|
|||
|
|
@ -161,17 +161,14 @@ theorem ex₂ (x y z : Int) (f : Int → Int) : x + f y + 2 + f y + z + z ≤ f
|
|||
info: theorem ex₂ : ∀ (x y z : Int) (f : Int → Int), x + f y + 2 + f y + z + z ≤ f y + 3 * z + 1 + 1 + x + f y - z :=
|
||||
fun x y z f =>
|
||||
of_eq_true
|
||||
((fun x_1 =>
|
||||
id
|
||||
(le_eq_true
|
||||
(Lean.RArray.branch 1 (Lean.RArray.leaf x_1)
|
||||
(Lean.RArray.branch 2 (Lean.RArray.leaf z) (Lean.RArray.leaf x)))
|
||||
((((((Expr.var 2).add (Expr.var 0)).add (Expr.num 2)).add (Expr.var 0)).add (Expr.var 1)).add (Expr.var 1))
|
||||
(((((((Expr.var 0).add (Expr.mulL 3 (Expr.var 1))).add (Expr.num 1)).add (Expr.num 1)).add (Expr.var 2)).add
|
||||
(Expr.var 0)).sub
|
||||
(Expr.var 1))
|
||||
(eagerReduce (Eq.refl true))))
|
||||
(f y))
|
||||
(id
|
||||
(le_eq_true
|
||||
(Lean.RArray.branch 1 (Lean.RArray.leaf (f y)) (Lean.RArray.branch 2 (Lean.RArray.leaf z) (Lean.RArray.leaf x)))
|
||||
((((((Expr.var 2).add (Expr.var 0)).add (Expr.num 2)).add (Expr.var 0)).add (Expr.var 1)).add (Expr.var 1))
|
||||
(((((((Expr.var 0).add (Expr.mulL 3 (Expr.var 1))).add (Expr.num 1)).add (Expr.num 1)).add (Expr.var 2)).add
|
||||
(Expr.var 0)).sub
|
||||
(Expr.var 1))
|
||||
(eagerReduce (Eq.refl true))))
|
||||
-/
|
||||
#guard_msgs (info) in
|
||||
open Int.Linear in
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue