From c9f4a412763ef46ed20c72a9d7fe2cca817d3817 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 14 Sep 2023 07:50:13 +0200 Subject: Fix panic issues with the progress tactic --- backends/lean/Base/Progress/Progress.lean | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 6a4729dc..afe3056e 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -314,12 +314,14 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do else pure none let ids := let args := asArgs.getArgs - let args := (args.get! 2).getSepArgs - args.map (λ s => if s.isIdent then some s.getId else none) + if args.size > 2 then + let args := (args.get! 2).getSepArgs + args.map (λ s => if s.isIdent then some s.getId else none) + else #[] trace[Progress] "User-provided ids: {ids}" let splitPost : Bool := let args := asArgs.getArgs - (args.get! 3).getArgs.size > 0 + args.size > 3 ∧ (args.get! 3).getArgs.size > 0 trace[Progress] "Split post: {splitPost}" /- For scalarTac we have a fast track: if the goal is not a linear arithmetic goal, we skip (note that otherwise, scalarTac would try -- cgit v1.3.1 From 743e8cb9d5366b879f53d7d0ba8adeb2f83ef72f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 14 Sep 2023 08:17:15 +0200 Subject: Fix the hashmap proofs in Lean --- backends/lean/Base/Progress/Progress.lean | 13 ++++----- backends/lean/Base/Utils.lean | 2 +- tests/lean/Hashmap/Properties.lean | 9 ++----- tests/lean/lake-manifest.json | 44 +++++++++++++++++++++---------- tests/lean/lean-toolchain | 2 +- 5 files changed, 41 insertions(+), 29 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index afe3056e..4fd88e36 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -110,8 +110,9 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) -- then continue splitting the post-condition splitEqAndPost fun hEq hPost ids => do trace[Progress] "eq and post:\n{hEq} : {← inferType hEq}\n{hPost}" - simpAt [] [``Primitives.bind_tc_ret, ``Primitives.bind_tc_fail, ``Primitives.bind_tc_div] - [hEq.fvarId!] (.targets #[] true) + tryTac ( + simpAt [] [``Primitives.bind_tc_ret, ``Primitives.bind_tc_fail, ``Primitives.bind_tc_div] + [hEq.fvarId!] (.targets #[] true)) -- Clear the equality, unless the user requests not to do so let mgoal ← do if keep.isSome then getMainGoal @@ -345,11 +346,11 @@ elab "progress" args:progressArgs : tactic => namespace Test open Primitives Result - set_option trace.Progress true - set_option pp.rawOnError true + -- set_option trace.Progress true + -- set_option pp.rawOnError true - #eval showStoredPSpec - #eval showStoredPSpecClass + -- #eval showStoredPSpec + -- #eval showStoredPSpecClass example {ty} {x y : Scalar ty} (hmin : Scalar.min ty ≤ x.val + y.val) diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index e58198f4..5224e1c3 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -303,7 +303,7 @@ example (x : Bool) : Nat := by -- Attempt to apply a tactic def tryTac (tac : TacticM Unit) : TacticM Unit := do - let _ := tryTactic tac + let _ ← tryTactic tac -- Repeatedly apply a tactic partial def repeatTac (tac : TacticM Unit) : TacticM Unit := do diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index ab95b854..fe00ab14 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -332,12 +332,7 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value simp_all simp [inv] at hinv int_tac - -- TODO: progress fails in command line mode with "index out of bounds" - -- and I have no idea how to fix this. The error happens after progress - -- introduced the new goals. It must be when we exit the "withApp", etc. - -- helpers. - -- progress as ⟨ z, hp ⟩ - have ⟨ z, hp ⟩ := Usize.add_spec hbounds + progress as ⟨ z, hp ⟩ simp [hp] else simp [*, Pure.pure] @@ -408,7 +403,7 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value -- TODO: canonize addition by default? We need a tactic to simplify arithmetic equalities -- with addition and substractions ((ℤ, +) is a group or something - there should exist a tactic -- somewhere in mathlib?) - simp [Int.add_assoc, Int.add_comm, Int.add_left_comm] <;> + (try simp [Int.add_assoc, Int.add_comm, Int.add_left_comm]) <;> int_tac have hinv : inv nhm := by simp [inv] at * diff --git a/tests/lean/lake-manifest.json b/tests/lean/lake-manifest.json index 94030cb6..5c20ec3b 100644 --- a/tests/lean/lake-manifest.json +++ b/tests/lean/lake-manifest.json @@ -1,40 +1,56 @@ -{"version": 4, +{"version": 5, "packagesDir": "lake-packages", "packages": [{"git": {"url": "https://github.com/EdAyers/ProofWidgets4", "subDir?": null, - "rev": "c43db94a8f495dad37829e9d7ad65483d68c86b8", + "rev": "a0c2cd0ac3245a0dade4f925bcfa97e06dd84229", + "opts": {}, "name": "proofwidgets", - "inputRev?": "v0.0.11"}}, - {"path": {"name": "Base", "dir": "./../../backends/lean"}}, + "inputRev?": "v0.0.13", + "inherited": true}}, + {"path": + {"opts": {}, + "name": "Base", + "inherited": false, + "dir": "./../../backends/lean"}}, {"git": {"url": "https://github.com/mhuisi/lean4-cli.git", "subDir?": null, - "rev": "5a858c32963b6b19be0d477a30a1f4b6c120be7e", + "rev": "21dac2e9cc7e3cf7da5800814787b833e680b2fd", + "opts": {}, "name": "Cli", - "inputRev?": "nightly"}}, + "inputRev?": "nightly", + "inherited": true}}, {"git": {"url": "https://github.com/leanprover-community/mathlib4.git", "subDir?": null, - "rev": "fa05951a270fef2873666c46f138e90338cd48d6", + "rev": "b639e46a19a0328adfb9b1fdf8cbe39dfc1de76b", + "opts": {}, "name": "mathlib", - "inputRev?": null}}, + "inputRev?": null, + "inherited": false}}, {"git": {"url": "https://github.com/gebner/quote4", "subDir?": null, - "rev": "c0d9516f44d07feee01c1103c8f2f7c24a822b55", + "rev": "e75daed95ad1c92af4e577fea95e234d7a8401c1", + "opts": {}, "name": "Qq", - "inputRev?": "master"}}, + "inputRev?": "master", + "inherited": true}}, {"git": {"url": "https://github.com/JLimperg/aesop", "subDir?": null, - "rev": "f04538ab6ad07642368cf11d2702acc0a9b4bcee", + "rev": "1a0cded2be292b5496e659b730d2accc742de098", + "opts": {}, "name": "aesop", - "inputRev?": "master"}}, + "inputRev?": "master", + "inherited": true}}, {"git": {"url": "https://github.com/leanprover/std4", "subDir?": null, - "rev": "dff883c55395438ae2a5c65ad5ddba084b600feb", + "rev": "ba5e5e3af519b4fc5221ad0fa4b2c87276f1d323", + "opts": {}, "name": "std", - "inputRev?": "main"}}]} + "inputRev?": "main", + "inherited": true}}]} diff --git a/tests/lean/lean-toolchain b/tests/lean/lean-toolchain index 334c5053..fbca4d37 100644 --- a/tests/lean/lean-toolchain +++ b/tests/lean/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:nightly-2023-07-12 \ No newline at end of file +leanprover/lean4:v4.0.0 \ No newline at end of file -- cgit v1.3.1 From 888565dd83636522564c6fcae1571735b32125da Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 18 Sep 2023 10:08:20 +0200 Subject: Fix an issue when loading the saved theorem maps for the progress tactic --- backends/lean/Base/Progress/Base.lean | 57 +++++++++++++++++++++++++++++-- backends/lean/Base/Progress/Progress.lean | 14 ++++++++ 2 files changed, 68 insertions(+), 3 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index 6f820a84..76a92795 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -167,7 +167,8 @@ structure PSpecClassExprAttr where deriving Inhabited -- TODO: the original function doesn't define correctly the `addImportedFn`. Do a PR? -def mkMapDeclarationExtension [Inhabited α] (name : Name := by exact decl_name%) : IO (MapDeclarationExtension α) := +def mkMapDeclarationExtension [Inhabited α] (name : Name := by exact decl_name%) : + IO (MapDeclarationExtension α) := registerSimplePersistentEnvExtension { name := name, addImportedFn := fun a => a.foldl (fun s a => a.foldl (fun s (k, v) => s.insert k v) s) RBMap.empty, @@ -175,6 +176,54 @@ def mkMapDeclarationExtension [Inhabited α] (name : Name := by exact decl_name% toArrayFn := fun es => es.toArray.qsort (fun a b => Name.quickLt a.1 b.1) } +-- Declare an extension of maps of maps (using [RBMap]). +-- The important point is that we need to merge the bound values (which are maps). +def mkMapMapDeclarationExtension [Inhabited β] (ord : α → α → Ordering) + (name : Name := by exact decl_name%) : + IO (MapDeclarationExtension (RBMap α β ord)) := + registerSimplePersistentEnvExtension { + name := name, + addImportedFn := fun a => + a.foldl (fun s a => a.foldl ( + -- We need to merge the maps + fun s (k0, k1_to_v) => + match s.find? k0 with + | none => + -- No binding: insert one + s.insert k0 k1_to_v + | some m => + -- There is already a binding: merge + let m := RBMap.fold (fun m k v => m.insert k v) m k1_to_v + s.insert k0 m) + s) RBMap.empty, + addEntryFn := fun s n => s.insert n.1 n.2 , + toArrayFn := fun es => es.toArray.qsort (fun a b => Name.quickLt a.1 b.1) + } + +-- Declare an extension of maps of maps (using [HashMap]). +-- The important point is that we need to merge the bound values (which are maps). +def mkMapHashMapDeclarationExtension [BEq α] [Hashable α] [Inhabited β] + (name : Name := by exact decl_name%) : + IO (MapDeclarationExtension (HashMap α β)) := + registerSimplePersistentEnvExtension { + name := name, + addImportedFn := fun a => + a.foldl (fun s a => a.foldl ( + -- We need to merge the maps + fun s (k0, k1_to_v) => + match s.find? k0 with + | none => + -- No binding: insert one + s.insert k0 k1_to_v + | some m => + -- There is already a binding: merge + let m := HashMap.fold (fun m k v => m.insert k v) m k1_to_v + s.insert k0 m) + s) RBMap.empty, + addEntryFn := fun s n => s.insert n.1 n.2 , + toArrayFn := fun es => es.toArray.qsort (fun a b => Name.quickLt a.1 b.1) + } + /- The persistent map from function to pspec theorems. -/ initialize pspecAttr : PSpecAttr ← do let ext ← mkMapDeclarationExtension `pspecMap @@ -200,7 +249,8 @@ initialize pspecAttr : PSpecAttr ← do /- The persistent map from type classes to pspec theorems -/ initialize pspecClassAttr : PSpecClassAttr ← do - let ext : MapDeclarationExtension (NameMap Name) ← mkMapDeclarationExtension `pspecClassMap + let ext : MapDeclarationExtension (NameMap Name) ← + mkMapMapDeclarationExtension Name.quickCmp `pspecClassMap let attrImpl : AttributeImpl := { name := `cpspec descr := "Marks theorems to use for type classes with the `progress` tactic" @@ -231,7 +281,8 @@ initialize pspecClassAttr : PSpecClassAttr ← do /- The 2nd persistent map from type classes to pspec theorems -/ initialize pspecClassExprAttr : PSpecClassExprAttr ← do - let ext : MapDeclarationExtension (HashMap Expr Name) ← mkMapDeclarationExtension `pspecClassExprMap + let ext : MapDeclarationExtension (HashMap Expr Name) ← + mkMapHashMapDeclarationExtension `pspecClassExprMap let attrImpl : AttributeImpl := { name := `cepspec descr := "Marks theorems to use for type classes with the `progress` tactic" diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 4fd88e36..8b0759c5 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -243,21 +243,26 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL tryLookupApply keep ids splitPost asmTac fExpr "pspec theorem" pspec do -- It failed: try to lookup a *class* expr spec theorem (those are more -- specific than class spec theorems) + trace[Progress] "Failed using a pspec theorem: trying to lookup a pspec class expr theorem" let pspecClassExpr ← do match getFirstArg args with | none => pure none | some arg => do + trace[Progress] "Using: f:{fName}, arg: {arg}" let thName ← pspecClassExprAttr.find? fName arg pure (thName.map fun th => .Theorem th) tryLookupApply keep ids splitPost asmTac fExpr "pspec class expr theorem" pspecClassExpr do -- It failed: try to lookup a *class* spec theorem + trace[Progress] "Failed using a pspec class expr theorem: trying to lookup a pspec class theorem" let pspecClass ← do match ← getFirstArgAppName args with | none => pure none | some argName => do + trace[Progress] "Using: f: {fName}, arg: {argName}" let thName ← pspecClassAttr.find? fName argName pure (thName.map fun th => .Theorem th) tryLookupApply keep ids splitPost asmTac fExpr "pspec class theorem" pspecClass do + trace[Progress] "Failed using a pspec class theorem: trying to use a recursive assumption" -- Try a recursive call - we try the assumptions of kind "auxDecl" let ctx ← Lean.MonadLCtx.getLCtx let decls ← ctx.getAllDecls @@ -346,11 +351,14 @@ elab "progress" args:progressArgs : tactic => namespace Test open Primitives Result + -- Show the traces -- set_option trace.Progress true -- set_option pp.rawOnError true + -- The following commands display the databases of theorems -- #eval showStoredPSpec -- #eval showStoredPSpecClass + -- #eval showStoredPSpecExprClass example {ty} {x y : Scalar ty} (hmin : Scalar.min ty ≤ x.val + y.val) @@ -366,6 +374,12 @@ namespace Test progress keep h with Scalar.add_spec as ⟨ z ⟩ simp [*, h] + example {x y : U32} + (hmax : x.val + y.val ≤ U32.max) : + ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by + progress keep _ as ⟨ z, h1 .. ⟩ + simp [*, h1] + /- Checking that universe instantiation works: the original spec uses `α : Type u` where u is quantified, while here we use `α : Type 0` -/ example {α : Type} (v: Vec α) (i: Usize) (x : α) -- cgit v1.3.1