From 6166c410a4b3353377e640acbae9f56e877a9118 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 11 Jul 2023 15:23:49 +0200 Subject: Work on the progress tactic --- backends/lean/Base/Progress/Base.lean | 175 ++++++++++++++++++++++++++++++ backends/lean/Base/Progress/Progress.lean | 112 +++++++++++++++++++ 2 files changed, 287 insertions(+) create mode 100644 backends/lean/Base/Progress/Base.lean create mode 100644 backends/lean/Base/Progress/Progress.lean (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean new file mode 100644 index 00000000..3f44f46c --- /dev/null +++ b/backends/lean/Base/Progress/Base.lean @@ -0,0 +1,175 @@ +import Lean +import Base.Utils +import Base.Primitives + +namespace Progress + +open Lean Elab Term Meta +open Utils + +-- We can't define and use trace classes in the same file +initialize registerTraceClass `Progress + +-- Return the first conjunct if the expression is a conjunction, or the +-- expression itself otherwise. Also return the second conjunct if it is a +-- conjunction. +def getFirstConj (e : Expr) : MetaM (Expr × Option Expr) := do + e.withApp fun f args => + if f.isConstOf ``And ∧ args.size = 2 then pure (args.get! 0, some (args.get! 1)) + else pure (e, none) + +-- Destruct an equaliy and return the two sides +def destEq (e : Expr) : MetaM (Expr × Expr) := do + e.withApp fun f args => + if f.isConstOf ``Eq ∧ args.size = 3 then pure (args.get! 1, args.get! 2) + else throwError "Not an equality: {e}" + +-- Return the set of FVarIds in the expression +partial def getFVarIds (e : Expr) (hs : HashSet FVarId := HashSet.empty) : MetaM (HashSet FVarId) := do + e.withApp fun body args => do + let hs := if body.isFVar then hs.insert body.fvarId! else hs + args.foldlM (fun hs arg => getFVarIds arg hs) hs + +/- # Progress tactic -/ + +structure PSpecDesc where + -- The universally quantified variables + fvars : Array Expr + -- The existentially quantified variables + evars : Array Expr + -- The function + fName : Name + -- The function arguments + fLevels : List Level + args : Array Expr + -- The universally quantified variables which appear in the function arguments + argsFVars : Array FVarId + -- The returned value + ret : Expr + -- The postcondition (if there is) + post : Option Expr + +section Methods + variable [MonadLiftT MetaM m] [MonadControlT MetaM m] [Monad m] [MonadOptions m] + variable [MonadTrace m] [MonadLiftT IO m] [MonadRef m] [AddMessageContext m] + variable [MonadError m] + variable {a : Type} + + /- Analyze a pspec theorem to decompose its arguments. + + PSpec theorems should be of the following shape: + ``` + ∀ x1 ... xn, H1 → ... Hn → ∃ y1 ... ym. f x1 ... xn = .ret ... ∧ Post1 ∧ ... ∧ Postk + ``` + + The continuation `k` receives the following inputs: + - universally quantified variables + - assumptions + - existentially quantified variables + - function name + - function arguments + - return + - postconditions + + TODO: generalize for when we do inductive proofs + -/ + partial + def withPSpec [Inhabited (m a)] [Nonempty (m a)] (th : Expr) (k : PSpecDesc → m a) + (sanityChecks : Bool := false) : + m a := do + trace[Progress] "Theorem: {th}" + -- Dive into the quantified variables and the assumptions + forallTelescope th fun fvars th => do + trace[Progress] "All argumens: {fvars}" + /- -- Filter the argumens which are not propositions + let rec getFirstPropIdx (i : Nat) : MetaM Nat := do + if i ≥ fargs.size then pure i + else do + let x := fargs.get! i + if ← Meta.isProp (← inferType x) then pure i + else getFirstPropIdx (i + 1) + let i ← getFirstPropIdx 0 + let fvars := fargs.extract 0 i + let hyps := fargs.extract i fargs.size + trace[Progress] "Quantified variables: {fvars}" + trace[Progress] "Assumptions: {hyps}" + -- Sanity check: all hypotheses are propositions (in particular, all the + -- quantified variables are at the beginning) + let hypsAreProp ← hyps.allM fun x => do Meta.isProp (← inferType x) + if ¬ hypsAreProp then + throwError "The theorem doesn't have the proper shape: all the quantified arguments should be at the beginning" + -/ + -- Dive into the existentials + existsTelescope th fun evars th => do + trace[Progress] "Existentials: {evars}" + -- Take the first conjunct + let (th, post) ← getFirstConj th + -- Destruct the equality + let (th, ret) ← destEq th + -- Destruct the application to get the name + th.withApp fun f args => do + if ¬ f.isConst then throwError "Not a constant: {f}" + -- Compute the set of universally quantified variables which appear in the function arguments + let allArgsFVars ← args.foldlM (fun hs arg => getFVarIds arg hs) HashSet.empty + -- Sanity check + if sanityChecks then + let fvarsSet : HashSet FVarId := HashSet.ofArray (fvars.map (fun x => x.fvarId!)) + let filtArgsFVars := allArgsFVars.toArray.filter (fun fvar => ¬ fvarsSet.contains fvar) + if ¬ filtArgsFVars.isEmpty then + let filtArgsFVars := filtArgsFVars.map (fun fvarId => Expr.fvar fvarId) + throwError "Some of the function inputs are not universally quantified: {filtArgsFVars}" + let argsFVars := fvars.map (fun x => x.fvarId!) + let argsFVars := argsFVars.filter (fun fvar => allArgsFVars.contains fvar) + -- Return + trace[Progress] "Function: {f.constName!}"; + let thDesc := { + fvars := fvars + evars := evars + fName := f.constName! + fLevels := f.constLevels! + args := args + argsFVars + ret := ret + post := post + } + k thDesc +end Methods + + +def getPSpecFunName (th : Expr) : MetaM Name := + withPSpec th (fun d => do pure d.fName) true + +structure PSpecAttr where + attr : AttributeImpl + ext : MapDeclarationExtension Name + deriving Inhabited + +/- The persistent map from function to pspec theorems. -/ +initialize pspecAttr : PSpecAttr ← do + let ext ← mkMapDeclarationExtension `pspecMap + let attrImpl := { + name := `pspec + descr := "Marks theorems to use with the `progress` tactic" + add := fun thName stx attrKind => do + Attribute.Builtin.ensureNoArgs stx + -- TODO: use the attribute kind + unless attrKind == AttributeKind.global do + throwError "invalid attribute 'pspec', must be global" + -- Lookup the theorem + let env ← getEnv + let thDecl := env.constants.find! thName + let fName ← MetaM.run' (getPSpecFunName thDecl.type) + trace[Progress] "Registering spec theorem for {fName}" + let env := ext.addEntry env (fName, thName) + setEnv env + pure () + } + registerBuiltinAttribute attrImpl + pure { attr := attrImpl, ext := ext } + +def PSpecAttr.find? (s : PSpecAttr) (name : Name) : MetaM (Option Name) := do + return (s.ext.getState (← getEnv)).find? name + --return s.ext.find? (← getEnv) name + + +end Progress diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean new file mode 100644 index 00000000..1b9ee55c --- /dev/null +++ b/backends/lean/Base/Progress/Progress.lean @@ -0,0 +1,112 @@ +import Lean +import Base.Arith +import Base.Progress.Base + +namespace Progress + +open Lean Elab Term Meta Tactic +open Utils + +namespace Test + open Primitives + + set_option trace.Progress true + + @[pspec] + theorem vec_index_test (α : Type u) (v: Vec α) (i: Usize) (h: i.val < v.val.length) : + ∃ x, v.index α i = .ret x := by + apply + sorry + + #eval pspecAttr.find? ``Primitives.Vec.index +end Test + +#check isDefEq +#check allGoals + +def progressLookupTheorem (asmTac : TacticM Unit) : TacticM Unit := do + withMainContext do + -- Retrieve the goal + let mgoal ← Tactic.getMainGoal + let goalTy ← mgoal.getType + -- Dive into the goal to lookup the theorem + let (fName, fLevels, args) ← do + withPSpec goalTy fun desc => + -- TODO: check that no universally quantified variables in the arguments + pure (desc.fName, desc.fLevels, desc.args) + -- TODO: also try the assumptions + trace[Progress] "Function: {fName}" + -- TODO: use a list of theorems, and try them one by one? + let thName ← do + match ← pspecAttr.find? fName with + | none => throwError "Could not find a pspec theorem for {fName}" + | some thName => pure thName + trace[Progress] "Lookuped up: {thName}" + /- Apply the theorem + We try to match the theorem with the goal + In order to do so, we introduce meta-variables for all the parameters + (i.e., quantified variables and assumpions), and unify those with the goal. + Remark: we do not introduce meta-variables for the quantified variables + which don't appear in the function arguments (we want to let them + quantified). + We also make sure that all the meta variables which appear in the + function arguments have been instantiated + -/ + let env ← getEnv + let thDecl := env.constants.find! thName + let thTy := thDecl.type + -- TODO: the tactic fails if we uncomment withNewMCtxDepth + -- withNewMCtxDepth do + let (mvars, binders, thExBody) ← forallMetaTelescope thTy + -- Introduce the existentially quantified variables and the post-condition + -- in the context + let thBody ← + existsTelescope thExBody fun _evars thBody => do + let (thBody, _) ← destEq thBody + -- There shouldn't be any existential variables in thBody + pure thBody + -- Match the body with the target + let target := mkAppN (.const fName fLevels) args + trace[Progress] "mvars:\n{mvars.map Expr.mvarId!}" + trace[Progress] "thBody: {thBody}" + trace[Progress] "target: {target}" + let ok ← isDefEq thBody target + if ¬ ok then throwError "Could not unify the theorem with the target:\n- theorem: {thBody}\n- target: {target}" + postprocessAppMVars `progress mgoal mvars binders true true + Term.synthesizeSyntheticMVarsNoPostponing + let thBody ← instantiateMVars thBody + trace[Progress] "thBody (after instantiation): {thBody}" + -- Add the instantiated theorem to the assumptions (we apply it on the metavariables). + let th ← mkAppOptM thName (mvars.map some) + let asmName ← mkFreshUserName `h + let thTy ← inferType th + let thAsm ← Utils.addDecl asmName th thTy (asLet := false) + -- Update the set of goals + let curGoals ← getUnsolvedGoals + let newGoals := mvars.map Expr.mvarId! + let newGoals ← newGoals.filterM fun mvar => not <$> mvar.isAssigned + trace[Progress] "new goals: {newGoals}" + setGoals newGoals.toList + allGoals asmTac + let newGoals ← getUnsolvedGoals + setGoals (newGoals ++ curGoals) + -- + pure () + +elab "progress" : tactic => do + progressLookupTheorem (firstTac [assumptionTac, Arith.intTac]) + +namespace Test + open Primitives + + set_option trace.Progress true + + @[pspec] + theorem vec_index_test2 (α : Type u) (v: Vec α) (i: Usize) (h: i.val < v.val.length) : + ∃ x, v.index α i = .ret x := by + progress + tauto + +end Test + +end Progress -- cgit v1.3.1 From a18d899a2c2b9bdd36f4a5a4b70472c12a835a96 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 12 Jul 2023 14:34:55 +0200 Subject: Finish a first version of the progress tactic --- backends/lean/Base/Arith/Arith.lean | 122 ++++----------- backends/lean/Base/Diverge/Base.lean | 2 +- backends/lean/Base/Primitives.lean | 89 ++++++++--- backends/lean/Base/Progress/Base.lean | 24 +-- backends/lean/Base/Progress/Progress.lean | 36 ++++- backends/lean/Base/Utils.lean | 247 +++++++++++++++++++++++++++--- 6 files changed, 349 insertions(+), 171 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Arith/Arith.lean b/backends/lean/Base/Arith/Arith.lean index ff628cf3..3557d350 100644 --- a/backends/lean/Base/Arith/Arith.lean +++ b/backends/lean/Base/Arith/Arith.lean @@ -230,25 +230,20 @@ def introInstances (declToUnfold : Name) (lookup : Expr → MetaM (Option Expr)) let type ← inferType e let name ← mkFreshUserName `h -- Add a declaration - let nval ← Utils.addDecl name e type (asLet := false) + let nval ← Utils.addDeclTac name e type (asLet := false) -- Simplify to unfold the declaration to unfold (i.e., the projector) - let simpTheorems ← Tactic.simpOnlyBuiltins.foldlM (·.addConst ·) ({} : SimpTheorems) - -- Add the equational theorem for the decl to unfold - let simpTheorems ← simpTheorems.addDeclToUnfold declToUnfold - let congrTheorems ← getSimpCongrTheorems - let ctx : Simp.Context := { simpTheorems := #[simpTheorems], congrTheorems } - -- Where to apply the simplifier - let loc := Tactic.Location.targets #[mkIdent name] false - -- Apply the simplifier - let _ ← Tactic.simpLocation ctx (discharge? := .none) loc + Utils.simpAt [declToUnfold] [] [] (Tactic.Location.targets #[mkIdent name] false) -- Return the new value pure nval +def introHasPropInstances : Tactic.TacticM (Array Expr) := do + trace[Arith] "Introducing the HasProp instances" + introInstances ``HasProp.prop_ty lookupHasProp + -- Lookup the instances of `HasProp for all the sub-expressions in the context, -- and introduce the corresponding assumptions elab "intro_has_prop_instances" : tactic => do - trace[Arith] "Introducing the HasProp instances" - let _ ← introInstances ``HasProp.prop_ty lookupHasProp + let _ ← introHasPropInstances example (x y : U32) : x.val ≤ Scalar.max ScalarTy.U32 := by intro_has_prop_instances @@ -258,74 +253,6 @@ example {a: Type} (v : Vec a) : v.val.length ≤ Scalar.max ScalarTy.Usize := by intro_has_prop_instances simp_all [Scalar.max, Scalar.min] --- Tactic to split on a disjunction. --- The expression `h` should be an fvar. -def splitDisj (h : Expr) (kleft kright : Tactic.TacticM Unit) : Tactic.TacticM Unit := do - trace[Arith] "assumption on which to split: {h}" - -- Retrieve the main goal - Tactic.withMainContext do - let goalType ← Tactic.getMainTarget - let hDecl := (← getLCtx).get! h.fvarId! - let hName := hDecl.userName - -- Case disjunction - let hTy ← inferType h - hTy.withApp fun f xs => do - trace[Arith] "as app: {f} {xs}" - -- Sanity check - if ¬ (f.isConstOf ``Or ∧ xs.size = 2) then throwError "Invalid argument to splitDisj" - let a := xs.get! 0 - let b := xs.get! 1 - -- Introduce the new goals - -- Returns: - -- - the match branch - -- - a fresh new mvar id - let mkGoal (hTy : Expr) (nGoalName : String) : MetaM (Expr × MVarId) := do - -- Introduce a variable for the assumption (`a` or `b`). Note that we reuse - -- the name of the assumption we split. - withLocalDeclD hName hTy fun var => do - -- The new goal - let mgoal ← mkFreshExprSyntheticOpaqueMVar goalType (tag := Name.mkSimple nGoalName) - -- Clear the assumption that we split - let mgoal ← mgoal.mvarId!.tryClearMany #[h.fvarId!] - -- The branch expression - let branch ← mkLambdaFVars #[var] (mkMVar mgoal) - pure (branch, mgoal) - let (inl, mleft) ← mkGoal a "left" - let (inr, mright) ← mkGoal b "right" - trace[Arith] "left: {inl}: {mleft}" - trace[Arith] "right: {inr}: {mright}" - -- Create the match expression - withLocalDeclD (← mkFreshUserName `h) hTy fun hVar => do - let motive ← mkLambdaFVars #[hVar] goalType - let casesExpr ← mkAppOptM ``Or.casesOn #[a, b, motive, h, inl, inr] - let mgoal ← Tactic.getMainGoal - trace[Arith] "goals: {← Tactic.getUnsolvedGoals}" - trace[Arith] "main goal: {mgoal}" - mgoal.assign casesExpr - let goals ← Tactic.getUnsolvedGoals - -- Focus on the left - Tactic.setGoals [mleft] - kleft - let leftGoals ← Tactic.getUnsolvedGoals - -- Focus on the right - Tactic.setGoals [mright] - kright - let rightGoals ← Tactic.getUnsolvedGoals - -- Put all the goals back - Tactic.setGoals (leftGoals ++ rightGoals ++ goals) - trace[Arith] "new goals: {← Tactic.getUnsolvedGoals}" - -elab "split_disj " n:ident : tactic => do - Tactic.withMainContext do - let decl ← Lean.Meta.getLocalDeclFromUserName n.getId - let fvar := mkFVar decl.fvarId - splitDisj fvar (fun _ => pure ()) (fun _ => pure ()) - -example (x y : Int) (h0 : x ≤ y ∨ x ≥ y) : x ≤ y ∨ x ≥ y := by - split_disj h0 - . left; assumption - . right; assumption - -- Lookup the instances of `PropHasImp for all the sub-expressions in the context, -- and introduce the corresponding assumptions elab "intro_prop_has_imp_instances" : tactic => do @@ -357,7 +284,7 @@ def intTacPreprocess : Tactic.TacticM Unit := do | [] => pure () | asm :: asms => let k := splitOnAsms asms - splitDisj asm k k + Utils.splitDisjTac asm k k -- Introduce let asms ← introInstances ``PropHasImp.concl lookupPropHasImp -- Split @@ -403,18 +330,27 @@ example (x y : Int) (h0: 0 ≤ x) (h1: x ≠ 0) (h2 : 0 ≤ y) (h3 : y ≠ 0) : int_tac -- A tactic to solve linear arithmetic goals in the presence of scalars -syntax "scalar_tac" : tactic -macro_rules - | `(tactic| scalar_tac) => - `(tactic| - intro_has_prop_instances; - have := Scalar.cMin_bound ScalarTy.Usize; - have := Scalar.cMin_bound ScalarTy.Isize; - have := Scalar.cMax_bound ScalarTy.Usize; - have := Scalar.cMax_bound ScalarTy.Isize; - -- TODO: not too sure about that - simp only [*, Scalar.max, Scalar.min, Scalar.cMin, Scalar.cMax] at *; - int_tac) +def scalarTac : Tactic.TacticM Unit := do + Tactic.withMainContext do + -- Introduce the scalar bounds + let _ ← introHasPropInstances + Tactic.allGoals do + -- Inroduce the bounds for the isize/usize types + let add (e : Expr) : Tactic.TacticM Unit := do + let ty ← inferType e + let _ ← Utils.addDeclTac (← mkFreshUserName `h) e ty (asLet := false) + add (← mkAppM ``Scalar.cMin_bound #[.const ``ScalarTy.Usize []]) + add (← mkAppM ``Scalar.cMin_bound #[.const ``ScalarTy.Isize []]) + add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Usize []]) + add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Isize []]) + -- Reveal the concrete bounds - TODO: not too sure about that. + -- Maybe we should reveal the "concrete" bounds (after normalization) + Utils.simpAt [``Scalar.max, ``Scalar.min, ``Scalar.cMin, ``Scalar.cMax] [] [] .wildcard + -- Apply the integer tactic + intTac + +elab "scalar_tac" : tactic => + scalarTac example (x y : U32) : x.val ≤ Scalar.max ScalarTy.U32 := by scalar_tac diff --git a/backends/lean/Base/Diverge/Base.lean b/backends/lean/Base/Diverge/Base.lean index e22eb914..d2c91ff8 100644 --- a/backends/lean/Base/Diverge/Base.lean +++ b/backends/lean/Base/Diverge/Base.lean @@ -14,7 +14,7 @@ TODO: Actually, the cases from mathlib seems already quite powerful (https://leanprover-community.github.io/mathlib_docs/tactics.html#cases) For instance: cases h : e - Also: cases_matching + Also: **casesm** - better split tactic - we need conversions to operate on the head of applications. Actually, something like this works: diff --git a/backends/lean/Base/Primitives.lean b/backends/lean/Base/Primitives.lean index 14f5971e..6210688d 100644 --- a/backends/lean/Base/Primitives.lean +++ b/backends/lean/Base/Primitives.lean @@ -175,27 +175,28 @@ open System.Platform.getNumBits @[simp] def U128.min : Int := 0 @[simp] def U128.max : Int := HPow.hPow 2 128 - 1 -#assert (I8.min == -128) -#assert (I8.max == 127) -#assert (I16.min == -32768) -#assert (I16.max == 32767) -#assert (I32.min == -2147483648) -#assert (I32.max == 2147483647) -#assert (I64.min == -9223372036854775808) -#assert (I64.max == 9223372036854775807) -#assert (I128.min == -170141183460469231731687303715884105728) -#assert (I128.max == 170141183460469231731687303715884105727) -#assert (U8.min == 0) -#assert (U8.max == 255) -#assert (U16.min == 0) -#assert (U16.max == 65535) -#assert (U32.min == 0) -#assert (U32.max == 4294967295) -#assert (U64.min == 0) -#assert (U64.max == 18446744073709551615) -#assert (U128.min == 0) -#assert (U128.max == 340282366920938463463374607431768211455) - +-- The normalized bounds +@[simp] def I8.norm_min := -128 +@[simp] def I8.norm_max := 127 +@[simp] def I16.norm_min := -32768 +@[simp] def I16.norm_max := 32767 +@[simp] def I32.norm_min := -2147483648 +@[simp] def I32.norm_max := 2147483647 +@[simp] def I64.norm_min := -9223372036854775808 +@[simp] def I64.norm_max := 9223372036854775807 +@[simp] def I128.norm_min := -170141183460469231731687303715884105728 +@[simp] def I128.norm_max := 170141183460469231731687303715884105727 +@[simp] def U8.norm_min := 0 +@[simp] def U8.norm_max := 255 +@[simp] def U16.norm_min := 0 +@[simp] def U16.norm_max := 65535 +@[simp] def U32.norm_min := 0 +@[simp] def U32.norm_max := 4294967295 +@[simp] def U64.norm_min := 0 +@[simp] def U64.norm_max := 18446744073709551615 +@[simp] def U128.norm_min := 0 +@[simp] def U128.norm_max := 340282366920938463463374607431768211455 + inductive ScalarTy := | Isize | I8 @@ -240,6 +241,46 @@ def Scalar.max (ty : ScalarTy) : Int := | .U64 => U64.max | .U128 => U128.max +@[simp] def Scalar.norm_min (ty : ScalarTy) : Int := + match ty with + -- We can't normalize the bounds for isize/usize + | .Isize => Isize.min + | .Usize => Usize.min + -- + | .I8 => I8.norm_min + | .I16 => I16.norm_min + | .I32 => I32.norm_min + | .I64 => I64.norm_min + | .I128 => I128.norm_min + | .U8 => U8.norm_min + | .U16 => U16.norm_min + | .U32 => U32.norm_min + | .U64 => U64.norm_min + | .U128 => U128.norm_min + +@[simp] def Scalar.norm_max (ty : ScalarTy) : Int := + match ty with + -- We can't normalize the bounds for isize/usize + | .Isize => Isize.max + | .Usize => Usize.max + -- + | .I8 => I8.norm_max + | .I16 => I16.norm_max + | .I32 => I32.norm_max + | .I64 => I64.norm_max + | .I128 => I128.norm_max + | .U8 => U8.norm_max + | .U16 => U16.norm_max + | .U32 => U32.norm_max + | .U64 => U64.norm_max + | .U128 => U128.norm_max + +def Scalar.norm_min_eq (ty : ScalarTy) : Scalar.min ty = Scalar.norm_min ty := by + cases ty <;> rfl + +def Scalar.norm_max_eq (ty : ScalarTy) : Scalar.max ty = Scalar.norm_max ty := by + cases ty <;> rfl + -- "Conservative" bounds -- We use those because we can't compare to the isize bounds (which can't -- reduce at compile-time). Whenever we perform an arithmetic operation like @@ -249,13 +290,13 @@ def Scalar.max (ty : ScalarTy) : Int := -- type-checking time. def Scalar.cMin (ty : ScalarTy) : Int := match ty with - | .Isize => I32.min + | .Isize => Scalar.min .I32 | _ => Scalar.min ty def Scalar.cMax (ty : ScalarTy) : Int := match ty with - | .Isize => I32.max - | .Usize => U32.max + | .Isize => Scalar.max .I32 + | .Usize => Scalar.max .U32 | _ => Scalar.max ty theorem Scalar.cMin_bound ty : Scalar.min ty ≤ Scalar.cMin ty := by diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index 3f44f46c..613f38f8 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -10,26 +10,6 @@ open Utils -- We can't define and use trace classes in the same file initialize registerTraceClass `Progress --- Return the first conjunct if the expression is a conjunction, or the --- expression itself otherwise. Also return the second conjunct if it is a --- conjunction. -def getFirstConj (e : Expr) : MetaM (Expr × Option Expr) := do - e.withApp fun f args => - if f.isConstOf ``And ∧ args.size = 2 then pure (args.get! 0, some (args.get! 1)) - else pure (e, none) - --- Destruct an equaliy and return the two sides -def destEq (e : Expr) : MetaM (Expr × Expr) := do - e.withApp fun f args => - if f.isConstOf ``Eq ∧ args.size = 3 then pure (args.get! 1, args.get! 2) - else throwError "Not an equality: {e}" - --- Return the set of FVarIds in the expression -partial def getFVarIds (e : Expr) (hs : HashSet FVarId := HashSet.empty) : MetaM (HashSet FVarId) := do - e.withApp fun body args => do - let hs := if body.isFVar then hs.insert body.fvarId! else hs - args.foldlM (fun hs arg => getFVarIds arg hs) hs - /- # Progress tactic -/ structure PSpecDesc where @@ -103,7 +83,7 @@ section Methods existsTelescope th fun evars th => do trace[Progress] "Existentials: {evars}" -- Take the first conjunct - let (th, post) ← getFirstConj th + let (th, post) ← optSplitConj th -- Destruct the equality let (th, ret) ← destEq th -- Destruct the application to get the name @@ -169,7 +149,5 @@ initialize pspecAttr : PSpecAttr ← do def PSpecAttr.find? (s : PSpecAttr) (name : Name) : MetaM (Option Name) := do return (s.ext.getState (← getEnv)).find? name - --return s.ext.find? (← getEnv) name - end Progress diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 1b9ee55c..4c68b3bd 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -21,9 +21,6 @@ namespace Test #eval pspecAttr.find? ``Primitives.Vec.index end Test -#check isDefEq -#check allGoals - def progressLookupTheorem (asmTac : TacticM Unit) : TacticM Unit := do withMainContext do -- Retrieve the goal @@ -80,7 +77,28 @@ def progressLookupTheorem (asmTac : TacticM Unit) : TacticM Unit := do let th ← mkAppOptM thName (mvars.map some) let asmName ← mkFreshUserName `h let thTy ← inferType th - let thAsm ← Utils.addDecl asmName th thTy (asLet := false) + let thAsm ← Utils.addDeclTac asmName th thTy (asLet := false) + withMainContext do -- The context changed - TODO: remove once addDeclTac is updated + let ngoal ← getMainGoal + trace[Progress] "current goal: {ngoal}" + trace[Progress] "current goal: {← ngoal.isAssigned}" + -- The assumption should be of the shape: + -- `∃ x1 ... xn, f args = ... ∧ ...` + -- We introduce the existentially quantified variables and split the top-most + -- conjunction if there is one + splitAllExistsTac thAsm fun h => do + -- Split the conjunction + let splitConj (k : Expr → TacticM Unit) : TacticM Unit := do + if ← isConj (← inferType h) then + splitConjTac h (fun h _ => k h) + else k h + -- Simplify the target by using the equality + splitConj fun h => do + simpAt [] [] [h.fvarId!] (.targets #[] true) + -- Clear the equality + let mgoal ← getMainGoal + let mgoal ← mgoal.tryClearMany #[h.fvarId!] + setGoals (mgoal :: (← getUnsolvedGoals)) -- Update the set of goals let curGoals ← getUnsolvedGoals let newGoals := mvars.map Expr.mvarId! @@ -94,7 +112,7 @@ def progressLookupTheorem (asmTac : TacticM Unit) : TacticM Unit := do pure () elab "progress" : tactic => do - progressLookupTheorem (firstTac [assumptionTac, Arith.intTac]) + progressLookupTheorem (firstTac [assumptionTac, Arith.scalarTac]) namespace Test open Primitives @@ -103,10 +121,12 @@ namespace Test @[pspec] theorem vec_index_test2 (α : Type u) (v: Vec α) (i: Usize) (h: i.val < v.val.length) : - ∃ x, v.index α i = .ret x := by + ∃ (x: α), v.index α i = .ret x := by progress - tauto - + simp + + set_option trace.Progress false + end Test end Progress diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index 1351f3d4..14feb567 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -1,9 +1,10 @@ import Lean import Mathlib.Tactic.Core +import Mathlib.Tactic.LeftRight namespace Utils -open Lean Elab Term Meta +open Lean Elab Term Meta Tactic -- Useful helper to explore definitions and figure out the variant -- of their sub-expressions. @@ -156,9 +157,10 @@ section Methods end Methods -def addDecl (name : Name) (val : Expr) (type : Expr) (asLet : Bool) : Tactic.TacticM Expr := +-- TODO: this should take a continuation +def addDeclTac (name : Name) (val : Expr) (type : Expr) (asLet : Bool) : TacticM Expr := -- I don't think we need that - Lean.Elab.Tactic.withMainContext do + withMainContext do -- Insert the new declaration let withDecl := if asLet then withLetDecl name type val else withLocalDeclD name type withDecl fun nval => do @@ -169,7 +171,7 @@ def addDecl (name : Name) (val : Expr) (type : Expr) (asLet : Bool) : Tactic.Tac trace[Arith] " new decl: \"{decl.userName}\" ({nval}) : {decl.type} := {decl.value}" -- -- Tranform the main goal `?m0` to `let x = nval in ?m1` - let mvarId ← Tactic.getMainGoal + let mvarId ← getMainGoal let newMVar ← mkFreshExprSyntheticOpaqueMVar (← mvarId.getType) let newVal ← mkLetFVars #[nval] newMVar -- There are two cases: @@ -179,30 +181,30 @@ def addDecl (name : Name) (val : Expr) (type : Expr) (asLet : Bool) : Tactic.Tac let newVal := if asLet then newVal else mkAppN newVal #[val] -- Assign the main goal and update the current goal mvarId.assign newVal - let goals ← Tactic.getUnsolvedGoals - Lean.Elab.Tactic.setGoals (newMVar.mvarId! :: goals) + let goals ← getUnsolvedGoals + setGoals (newMVar.mvarId! :: goals) -- Return the new value - note: we are in the *new* context, created -- after the declaration was added, so it will persist pure nval -def addDeclSyntax (name : Name) (val : Syntax) (asLet : Bool) : Tactic.TacticM Unit := +def addDeclTacSyntax (name : Name) (val : Syntax) (asLet : Bool) : TacticM Unit := -- I don't think we need that - Lean.Elab.Tactic.withMainContext do + withMainContext do -- - let val ← elabTerm val .none + let val ← Term.elabTerm val .none let type ← inferType val -- In some situations, the type will be left as a metavariable (for instance, -- if the term is `3`, Lean has the choice between `Nat` and `Int` and will -- not choose): we force the instantiation of the meta-variable synthesizeSyntheticMVarsUsingDefault -- - let _ ← addDecl name val type asLet + let _ ← addDeclTac name val type asLet elab "custom_let " n:ident " := " v:term : tactic => do - addDeclSyntax n.getId v (asLet := true) + addDeclTacSyntax n.getId v (asLet := true) elab "custom_have " n:ident " := " v:term : tactic => - addDeclSyntax n.getId v (asLet := false) + addDeclTacSyntax n.getId v (asLet := false) example : Nat := by custom_let x := 4 @@ -213,14 +215,14 @@ example (x : Bool) : Nat := by cases x <;> custom_let x := 3 <;> apply x -- Repeatedly apply a tactic -partial def repeatTac (tac : Tactic.TacticM Unit) : Tactic.TacticM Unit := do +partial def repeatTac (tac : TacticM Unit) : TacticM Unit := do try tac - Tactic.allGoals (Tactic.focus (repeatTac tac)) + allGoals (focus (repeatTac tac)) -- TODO: does this restore the state? catch _ => pure () -def firstTac (tacl : List (Tactic.TacticM Unit)) : Tactic.TacticM Unit := do +def firstTac (tacl : List (TacticM Unit)) : TacticM Unit := do match tacl with | [] => pure () | tac :: tacl => @@ -228,15 +230,216 @@ def firstTac (tacl : List (Tactic.TacticM Unit)) : Tactic.TacticM Unit := do catch _ => firstTac tacl -- Split the goal if it is a conjunction -def splitConjTarget : Tactic.TacticM Unit := do - Tactic.withMainContext do +def splitConjTarget : TacticM Unit := do + withMainContext do let and_intro := Expr.const ``And.intro [] - let mvarIds' ← _root_.Lean.MVarId.apply (← Tactic.getMainGoal) and_intro + let mvarIds' ← _root_.Lean.MVarId.apply (← getMainGoal) and_intro Term.synthesizeSyntheticMVarsNoPostponing - Tactic.replaceMainGoal mvarIds' + replaceMainGoal mvarIds' --- Taken from Lean.Elab.Tactic.evalAssumption -def assumptionTac : Tactic.TacticM Unit := - Tactic.liftMetaTactic fun mvarId => do mvarId.assumption; pure [] +-- Taken from Lean.Elab.evalAssumption +def assumptionTac : TacticM Unit := + liftMetaTactic fun mvarId => do mvarId.assumption; pure [] + +def isConj (e : Expr) : MetaM Bool := + e.withApp fun f args => pure (f.isConstOf ``And ∧ args.size = 2) + +-- Return the first conjunct if the expression is a conjunction, or the +-- expression itself otherwise. Also return the second conjunct if it is a +-- conjunction. +def optSplitConj (e : Expr) : MetaM (Expr × Option Expr) := do + e.withApp fun f args => + if f.isConstOf ``And ∧ args.size = 2 then pure (args.get! 0, some (args.get! 1)) + else pure (e, none) + +-- Destruct an equaliy and return the two sides +def destEq (e : Expr) : MetaM (Expr × Expr) := do + e.withApp fun f args => + if f.isConstOf ``Eq ∧ args.size = 3 then pure (args.get! 1, args.get! 2) + else throwError "Not an equality: {e}" + +-- Return the set of FVarIds in the expression +partial def getFVarIds (e : Expr) (hs : HashSet FVarId := HashSet.empty) : MetaM (HashSet FVarId) := do + e.withApp fun body args => do + let hs := if body.isFVar then hs.insert body.fvarId! else hs + args.foldlM (fun hs arg => getFVarIds arg hs) hs + +-- Tactic to split on a disjunction. +-- The expression `h` should be an fvar. +-- TODO: there must be simpler. Use use _root_.Lean.MVarId.cases for instance +def splitDisjTac (h : Expr) (kleft kright : TacticM Unit) : TacticM Unit := do + trace[Arith] "assumption on which to split: {h}" + -- Retrieve the main goal + withMainContext do + let goalType ← getMainTarget + let hDecl := (← getLCtx).get! h.fvarId! + let hName := hDecl.userName + -- Case disjunction + let hTy ← inferType h + hTy.withApp fun f xs => do + trace[Arith] "as app: {f} {xs}" + -- Sanity check + if ¬ (f.isConstOf ``Or ∧ xs.size = 2) then throwError "Invalid argument to splitDisjTac" + let a := xs.get! 0 + let b := xs.get! 1 + -- Introduce the new goals + -- Returns: + -- - the match branch + -- - a fresh new mvar id + let mkGoal (hTy : Expr) (nGoalName : String) : MetaM (Expr × MVarId) := do + -- Introduce a variable for the assumption (`a` or `b`). Note that we reuse + -- the name of the assumption we split. + withLocalDeclD hName hTy fun var => do + -- The new goal + let mgoal ← mkFreshExprSyntheticOpaqueMVar goalType (tag := Name.mkSimple nGoalName) + -- Clear the assumption that we split + let mgoal ← mgoal.mvarId!.tryClearMany #[h.fvarId!] + -- The branch expression + let branch ← mkLambdaFVars #[var] (mkMVar mgoal) + pure (branch, mgoal) + let (inl, mleft) ← mkGoal a "left" + let (inr, mright) ← mkGoal b "right" + trace[Arith] "left: {inl}: {mleft}" + trace[Arith] "right: {inr}: {mright}" + -- Create the match expression + withLocalDeclD (← mkFreshUserName `h) hTy fun hVar => do + let motive ← mkLambdaFVars #[hVar] goalType + let casesExpr ← mkAppOptM ``Or.casesOn #[a, b, motive, h, inl, inr] + let mgoal ← getMainGoal + trace[Arith] "goals: {← getUnsolvedGoals}" + trace[Arith] "main goal: {mgoal}" + mgoal.assign casesExpr + let goals ← getUnsolvedGoals + -- Focus on the left + setGoals [mleft] + withMainContext kleft + let leftGoals ← getUnsolvedGoals + -- Focus on the right + setGoals [mright] + withMainContext kright + let rightGoals ← getUnsolvedGoals + -- Put all the goals back + setGoals (leftGoals ++ rightGoals ++ goals) + trace[Arith] "new goals: {← getUnsolvedGoals}" + +elab "split_disj " n:ident : tactic => do + withMainContext do + let decl ← Lean.Meta.getLocalDeclFromUserName n.getId + let fvar := mkFVar decl.fvarId + splitDisjTac fvar (fun _ => pure ()) (fun _ => pure ()) + +example (x y : Int) (h0 : x ≤ y ∨ x ≥ y) : x ≤ y ∨ x ≥ y := by + split_disj h0 + . left; assumption + . right; assumption + + +-- Tactic to split on an exists +def splitExistsTac (h : Expr) (k : Expr → Expr → TacticM α) : TacticM α := do + withMainContext do + let goal ← getMainGoal + let hTy ← inferType h + if isExists hTy then do + let newGoals ← goal.cases h.fvarId! #[] + -- There should be exactly one goal + match newGoals.toList with + | [ newGoal ] => + -- Set the new goal + let goals ← getUnsolvedGoals + setGoals (newGoal.mvarId :: goals) + -- There should be exactly two fields + let fields := newGoal.fields + withMainContext do + k (fields.get! 0) (fields.get! 1) + | _ => + throwError "Unreachable" + else + throwError "Not a conjunction" + +partial def splitAllExistsTac [Inhabited α] (h : Expr) (k : Expr → TacticM α) : TacticM α := do + try + splitExistsTac h (fun _ body => splitAllExistsTac body k) + catch _ => k h + +-- Tactic to split on a conjunction. +def splitConjTac (h : Expr) (k : Expr → Expr → TacticM α) : TacticM α := do + withMainContext do + let goal ← getMainGoal + let hTy ← inferType h + if ← isConj hTy then do + let newGoals ← goal.cases h.fvarId! #[] + -- There should be exactly one goal + match newGoals.toList with + | [ newGoal ] => + -- Set the new goal + let goals ← getUnsolvedGoals + setGoals (newGoal.mvarId :: goals) + -- There should be exactly two fields + let fields := newGoal.fields + withMainContext do + k (fields.get! 0) (fields.get! 1) + | _ => + throwError "Unreachable" + else + throwError "Not a conjunction" + +elab "split_conj " n:ident : tactic => do + withMainContext do + let decl ← Lean.Meta.getLocalDeclFromUserName n.getId + let fvar := mkFVar decl.fvarId + splitConjTac fvar (fun _ _ => pure ()) + +elab "split_all_exists " n:ident : tactic => do + withMainContext do + let decl ← Lean.Meta.getLocalDeclFromUserName n.getId + let fvar := mkFVar decl.fvarId + splitAllExistsTac fvar (fun _ => pure ()) + +example (h : a ∧ b) : a := by + split_all_exists h + split_conj h + assumption + +example (h : ∃ x y z, x + y + z ≥ 0) : ∃ x, x ≥ 0 := by + split_all_exists h + rename_i x y z h + exists x + y + z + +/- Call the simp tactic. + The initialization of the context is adapted from Tactic.elabSimpArgs. + Something very annoying is that there is no function which allows to + initialize a simp context without doing an elaboration - as a consequence + we write our own here. -/ +def simpAt (declsToUnfold : List Name) (thms : List Name) (hypsToUse : List FVarId) + (loc : Tactic.Location) : + Tactic.TacticM Unit := do + -- Initialize with the builtin simp theorems + let simpThms ← Tactic.simpOnlyBuiltins.foldlM (·.addConst ·) ({} : SimpTheorems) + -- Add the equational theorem for the declarations to unfold + let simpThms ← + declsToUnfold.foldlM (fun thms decl => thms.addDeclToUnfold decl) simpThms + -- Add the hypotheses and the rewriting theorems + let simpThms ← + hypsToUse.foldlM (fun thms fvarId => + -- post: TODO: don't know what that is + -- inv: invert the equality + thms.add (.fvar fvarId) #[] (mkFVar fvarId) (post := false) (inv := false) + -- thms.eraseCore (.fvar fvar) + ) simpThms + -- Add the rewriting theorems to use + let simpThms ← + thms.foldlM (fun thms thmName => do + let info ← getConstInfo thmName + if (← isProp info.type) then + -- post: TODO: don't know what that is + -- inv: invert the equality + thms.addConst thmName (post := false) (inv := false) + else + throwError "Not a proposition: {thmName}" + ) simpThms + let congrTheorems ← getSimpCongrTheorems + let ctx : Simp.Context := { simpTheorems := #[simpThms], congrTheorems } + -- Apply the simplifier + let _ ← Tactic.simpLocation ctx (discharge? := .none) loc end Utils -- cgit v1.3.1 From 59e4a06480b5365f48dc68de80f44841f94094ed Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 12 Jul 2023 15:41:29 +0200 Subject: Improve the handling of arithmetic bounds --- backends/lean/Base/Arith/Arith.lean | 8 +- backends/lean/Base/Primitives.lean | 228 +++++++++++++++--------------- backends/lean/Base/Progress/Progress.lean | 5 +- 3 files changed, 126 insertions(+), 115 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Arith/Arith.lean b/backends/lean/Base/Arith/Arith.lean index 3557d350..20420f36 100644 --- a/backends/lean/Base/Arith/Arith.lean +++ b/backends/lean/Base/Arith/Arith.lean @@ -339,13 +339,17 @@ def scalarTac : Tactic.TacticM Unit := do let add (e : Expr) : Tactic.TacticM Unit := do let ty ← inferType e let _ ← Utils.addDeclTac (← mkFreshUserName `h) e ty (asLet := false) - add (← mkAppM ``Scalar.cMin_bound #[.const ``ScalarTy.Usize []]) add (← mkAppM ``Scalar.cMin_bound #[.const ``ScalarTy.Isize []]) add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Usize []]) add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Isize []]) -- Reveal the concrete bounds - TODO: not too sure about that. -- Maybe we should reveal the "concrete" bounds (after normalization) - Utils.simpAt [``Scalar.max, ``Scalar.min, ``Scalar.cMin, ``Scalar.cMax] [] [] .wildcard + Utils.simpAt [``Scalar.min, ``Scalar.max, ``Scalar.cMin, ``Scalar.cMax, + ``I8.min, ``I16.min, ``I32.min, ``I64.min, ``I128.min, + ``I8.max, ``I16.max, ``I32.max, ``I64.max, ``I128.max, + ``U8.min, ``U16.min, ``U32.min, ``U64.min, ``U128.min, + ``U8.max, ``U16.max, ``U32.max, ``U64.max, ``U128.max + ] [] [] .wildcard -- Apply the integer tactic intTac diff --git a/backends/lean/Base/Primitives.lean b/backends/lean/Base/Primitives.lean index 6210688d..37abdede 100644 --- a/backends/lean/Base/Primitives.lean +++ b/backends/lean/Base/Primitives.lean @@ -149,54 +149,78 @@ open System.Platform.getNumBits @[simp] def size_num_bits : Nat := (System.Platform.getNumBits ()).val -- Remark: Lean seems to use < for the comparisons with the upper bounds by convention. --- We keep the F* convention for now. -@[simp] def Isize.min : Int := - (HPow.hPow 2 (size_num_bits - 1)) -@[simp] def Isize.max : Int := (HPow.hPow 2 (size_num_bits - 1)) - 1 -@[simp] def I8.min : Int := - (HPow.hPow 2 7) -@[simp] def I8.max : Int := HPow.hPow 2 7 - 1 -@[simp] def I16.min : Int := - (HPow.hPow 2 15) -@[simp] def I16.max : Int := HPow.hPow 2 15 - 1 -@[simp] def I32.min : Int := -(HPow.hPow 2 31) -@[simp] def I32.max : Int := HPow.hPow 2 31 - 1 -@[simp] def I64.min : Int := -(HPow.hPow 2 63) -@[simp] def I64.max : Int := HPow.hPow 2 63 - 1 -@[simp] def I128.min : Int := -(HPow.hPow 2 127) -@[simp] def I128.max : Int := HPow.hPow 2 127 - 1 -@[simp] def Usize.min : Int := 0 -@[simp] def Usize.max : Int := HPow.hPow 2 size_num_bits - 1 -@[simp] def U8.min : Int := 0 -@[simp] def U8.max : Int := HPow.hPow 2 8 - 1 -@[simp] def U16.min : Int := 0 -@[simp] def U16.max : Int := HPow.hPow 2 16 - 1 -@[simp] def U32.min : Int := 0 -@[simp] def U32.max : Int := HPow.hPow 2 32 - 1 -@[simp] def U64.min : Int := 0 -@[simp] def U64.max : Int := HPow.hPow 2 64 - 1 -@[simp] def U128.min : Int := 0 -@[simp] def U128.max : Int := HPow.hPow 2 128 - 1 - --- The normalized bounds -@[simp] def I8.norm_min := -128 -@[simp] def I8.norm_max := 127 -@[simp] def I16.norm_min := -32768 -@[simp] def I16.norm_max := 32767 -@[simp] def I32.norm_min := -2147483648 -@[simp] def I32.norm_max := 2147483647 -@[simp] def I64.norm_min := -9223372036854775808 -@[simp] def I64.norm_max := 9223372036854775807 -@[simp] def I128.norm_min := -170141183460469231731687303715884105728 -@[simp] def I128.norm_max := 170141183460469231731687303715884105727 -@[simp] def U8.norm_min := 0 -@[simp] def U8.norm_max := 255 -@[simp] def U16.norm_min := 0 -@[simp] def U16.norm_max := 65535 -@[simp] def U32.norm_min := 0 -@[simp] def U32.norm_max := 4294967295 -@[simp] def U64.norm_min := 0 -@[simp] def U64.norm_max := 18446744073709551615 -@[simp] def U128.norm_min := 0 -@[simp] def U128.norm_max := 340282366920938463463374607431768211455 - + +-- The "structured" bounds +def Isize.smin : Int := - (HPow.hPow 2 (size_num_bits - 1)) +def Isize.smax : Int := (HPow.hPow 2 (size_num_bits - 1)) - 1 +def I8.smin : Int := - (HPow.hPow 2 7) +def I8.smax : Int := HPow.hPow 2 7 - 1 +def I16.smin : Int := - (HPow.hPow 2 15) +def I16.smax : Int := HPow.hPow 2 15 - 1 +def I32.smin : Int := -(HPow.hPow 2 31) +def I32.smax : Int := HPow.hPow 2 31 - 1 +def I64.smin : Int := -(HPow.hPow 2 63) +def I64.smax : Int := HPow.hPow 2 63 - 1 +def I128.smin : Int := -(HPow.hPow 2 127) +def I128.smax : Int := HPow.hPow 2 127 - 1 +def Usize.smin : Int := 0 +def Usize.smax : Int := HPow.hPow 2 size_num_bits - 1 +def U8.smin : Int := 0 +def U8.smax : Int := HPow.hPow 2 8 - 1 +def U16.smin : Int := 0 +def U16.smax : Int := HPow.hPow 2 16 - 1 +def U32.smin : Int := 0 +def U32.smax : Int := HPow.hPow 2 32 - 1 +def U64.smin : Int := 0 +def U64.smax : Int := HPow.hPow 2 64 - 1 +def U128.smin : Int := 0 +def U128.smax : Int := HPow.hPow 2 128 - 1 + +-- The "normalized" bounds, that we use in practice +def I8.min := -128 +def I8.max := 127 +def I16.min := -32768 +def I16.max := 32767 +def I32.min := -2147483648 +def I32.max := 2147483647 +def I64.min := -9223372036854775808 +def I64.max := 9223372036854775807 +def I128.min := -170141183460469231731687303715884105728 +def I128.max := 170141183460469231731687303715884105727 +@[simp] def U8.min := 0 +def U8.max := 255 +@[simp] def U16.min := 0 +def U16.max := 65535 +@[simp] def U32.min := 0 +def U32.max := 4294967295 +@[simp] def U64.min := 0 +def U64.max := 18446744073709551615 +@[simp] def U128.min := 0 +def U128.max := 340282366920938463463374607431768211455 +@[simp] def Usize.min := 0 + +def Isize.refined_min : { n:Int // n = I32.min ∨ n = I64.min } := + ⟨ Isize.smin, by + simp [Isize.smin] + cases System.Platform.numBits_eq <;> + unfold System.Platform.numBits at * <;> simp [*] ⟩ + +def Isize.refined_max : { n:Int // n = I32.max ∨ n = I64.max } := + ⟨ Isize.smax, by + simp [Isize.smax] + cases System.Platform.numBits_eq <;> + unfold System.Platform.numBits at * <;> simp [*] ⟩ + +def Usize.refined_max : { n:Int // n = U32.max ∨ n = U64.max } := + ⟨ Usize.smax, by + simp [Usize.smax] + cases System.Platform.numBits_eq <;> + unfold System.Platform.numBits at * <;> simp [*] ⟩ + +def Isize.min := Isize.refined_min.val +def Isize.max := Isize.refined_max.val +def Usize.max := Usize.refined_max.val + inductive ScalarTy := | Isize | I8 @@ -211,6 +235,36 @@ inductive ScalarTy := | U64 | U128 +def Scalar.smin (ty : ScalarTy) : Int := + match ty with + | .Isize => Isize.smin + | .I8 => I8.smin + | .I16 => I16.smin + | .I32 => I32.smin + | .I64 => I64.smin + | .I128 => I128.smin + | .Usize => Usize.smin + | .U8 => U8.smin + | .U16 => U16.smin + | .U32 => U32.smin + | .U64 => U64.smin + | .U128 => U128.smin + +def Scalar.smax (ty : ScalarTy) : Int := + match ty with + | .Isize => Isize.smax + | .I8 => I8.smax + | .I16 => I16.smax + | .I32 => I32.smax + | .I64 => I64.smax + | .I128 => I128.smax + | .Usize => Usize.smax + | .U8 => U8.smax + | .U16 => U16.smax + | .U32 => U32.smax + | .U64 => U64.smax + | .U128 => U128.smax + def Scalar.min (ty : ScalarTy) : Int := match ty with | .Isize => Isize.min @@ -241,44 +295,10 @@ def Scalar.max (ty : ScalarTy) : Int := | .U64 => U64.max | .U128 => U128.max -@[simp] def Scalar.norm_min (ty : ScalarTy) : Int := - match ty with - -- We can't normalize the bounds for isize/usize - | .Isize => Isize.min - | .Usize => Usize.min - -- - | .I8 => I8.norm_min - | .I16 => I16.norm_min - | .I32 => I32.norm_min - | .I64 => I64.norm_min - | .I128 => I128.norm_min - | .U8 => U8.norm_min - | .U16 => U16.norm_min - | .U32 => U32.norm_min - | .U64 => U64.norm_min - | .U128 => U128.norm_min - -@[simp] def Scalar.norm_max (ty : ScalarTy) : Int := - match ty with - -- We can't normalize the bounds for isize/usize - | .Isize => Isize.max - | .Usize => Usize.max - -- - | .I8 => I8.norm_max - | .I16 => I16.norm_max - | .I32 => I32.norm_max - | .I64 => I64.norm_max - | .I128 => I128.norm_max - | .U8 => U8.norm_max - | .U16 => U16.norm_max - | .U32 => U32.norm_max - | .U64 => U64.norm_max - | .U128 => U128.norm_max - -def Scalar.norm_min_eq (ty : ScalarTy) : Scalar.min ty = Scalar.norm_min ty := by +def Scalar.smin_eq (ty : ScalarTy) : Scalar.min ty = Scalar.smin ty := by cases ty <;> rfl -def Scalar.norm_max_eq (ty : ScalarTy) : Scalar.max ty = Scalar.norm_max ty := by +def Scalar.smax_eq (ty : ScalarTy) : Scalar.max ty = Scalar.smax ty := by cases ty <;> rfl -- "Conservative" bounds @@ -301,30 +321,22 @@ def Scalar.cMax (ty : ScalarTy) : Int := theorem Scalar.cMin_bound ty : Scalar.min ty ≤ Scalar.cMin ty := by cases ty <;> simp [Scalar.min, Scalar.max, Scalar.cMin, Scalar.cMax] at * - cases System.Platform.numBits_eq <;> - unfold System.Platform.numBits at * <;> - simp [*] + have h := Isize.refined_min.property + cases h <;> simp [*, Isize.min] theorem Scalar.cMax_bound ty : Scalar.cMax ty ≤ Scalar.max ty := by - cases ty <;> simp [Scalar.min, Scalar.max, Scalar.cMin, Scalar.cMax] at * <;> - cases System.Platform.numBits_eq <;> - unfold System.Platform.numBits at * <;> - simp [*] + cases ty <;> simp [Scalar.min, Scalar.max, Scalar.cMin, Scalar.cMax] at * + . have h := Isize.refined_max.property + cases h <;> simp [*, Isize.max] + . have h := Usize.refined_max.property + cases h <;> simp [*, Usize.max] theorem Scalar.cMin_suffices ty (h : Scalar.cMin ty ≤ x) : Scalar.min ty ≤ x := by - cases ty <;> simp [Scalar.min, Scalar.max, Scalar.cMin, Scalar.cMax] at * <;> - cases System.Platform.numBits_eq <;> - unfold System.Platform.numBits at * <;> - simp [*] at * - -- TODO: I would have expected terms like `-(1 + 1) ^ 63` to be simplified + have := Scalar.cMin_bound ty linarith theorem Scalar.cMax_suffices ty (h : x ≤ Scalar.cMax ty) : x ≤ Scalar.max ty := by - cases ty <;> simp [Scalar.min, Scalar.max, Scalar.cMin, Scalar.cMax] at * <;> - cases System.Platform.numBits_eq <;> - unfold System.Platform.numBits at * <;> - simp [*] at * <;> - -- TODO: I would have expected terms like `-(1 + 1) ^ 63` to be simplified + have := Scalar.cMax_bound ty linarith structure Scalar (ty : ScalarTy) where @@ -609,7 +621,7 @@ def Vec.new (α : Type u): Vec α := ⟨ [], by apply Scalar.cMax_suffices .Usiz def Vec.len (α : Type u) (v : Vec α) : Usize := let ⟨ v, l ⟩ := v - Usize.ofIntCore (List.length v) (by simp [Scalar.min]) l + Usize.ofIntCore (List.length v) (by simp [Scalar.min, Usize.min]) l -- This shouldn't be used def Vec.push_fwd (α : Type u) (_ : Vec α) (_ : α) : Unit := () @@ -620,13 +632,9 @@ def Vec.push (α : Type u) (v : Vec α) (x : α) : Result (Vec α) let nlen := List.length v.val + 1 if h : nlen ≤ U32.max || nlen ≤ Usize.max then have h : nlen ≤ Usize.max := by - simp at * - cases System.Platform.numBits_eq <;> - unfold System.Platform.numBits at * <;> - simp [*] at * <;> - try assumption - cases h <;> - linarith + simp [Usize.max] at * + have hm := Usize.refined_max.property + cases h <;> cases hm <;> simp [U32.max, U64.max] at * <;> try linarith return ⟨ List.concat v.val x, by simp at *; assumption ⟩ else fail maximumSizeExceeded @@ -647,7 +655,6 @@ def Vec.insert (α : Type u) (v: Vec α) (i: Usize) (x: α): Result (Vec α) := .ret ⟨ List.set v.val i x, by have h: List.length v.val ≤ Usize.max := v.property simp [*] at * - assumption ⟩ else .fail arrayOutOfBounds @@ -688,7 +695,6 @@ def Vec.index_mut_back (α : Type u) (v: Vec α) (i: Usize) (x: α): Result (Vec .ret ⟨ List.set v.val i x, by have h: List.length v.val ≤ Usize.max := v.property simp [*] at * - assumption ⟩ else .fail arrayOutOfBounds diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 4c68b3bd..a4df5c96 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -92,9 +92,10 @@ def progressLookupTheorem (asmTac : TacticM Unit) : TacticM Unit := do if ← isConj (← inferType h) then splitConjTac h (fun h _ => k h) else k h - -- Simplify the target by using the equality + -- Simplify the target by using the equality and some monad simplifications splitConj fun h => do - simpAt [] [] [h.fvarId!] (.targets #[] true) + simpAt [] [``Primitives.bind_tc_ret, ``Primitives.bind_tc_fail, ``Primitives.bind_tc_div] + [h.fvarId!] (.targets #[] true) -- Clear the equality let mgoal ← getMainGoal let mgoal ← mgoal.tryClearMany #[h.fvarId!] -- cgit v1.3.1 From eb97bdb6761437e492bcf1a95b4fa43d2b69601b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 12 Jul 2023 18:04:19 +0200 Subject: Improve progress to use assumptions and start working on a nice syntax --- backends/lean/Base/Arith/Arith.lean | 42 +----------- backends/lean/Base/Diverge/Base.lean | 22 ------ backends/lean/Base/Progress/Base.lean | 2 +- backends/lean/Base/Progress/Progress.lean | 107 +++++++++++++++++++++--------- backends/lean/Base/Utils.lean | 62 +++++++++++++++++ 5 files changed, 140 insertions(+), 95 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Arith/Arith.lean b/backends/lean/Base/Arith/Arith.lean index 20420f36..ab4fd182 100644 --- a/backends/lean/Base/Arith/Arith.lean +++ b/backends/lean/Base/Arith/Arith.lean @@ -11,49 +11,9 @@ import Base.Primitives import Base.Utils import Base.Arith.Base -/- -Mathlib tactics: -- rcases: https://leanprover-community.github.io/mathlib_docs/tactics.html#rcases -- split_ifs: https://leanprover-community.github.io/mathlib_docs/tactics.html#split_ifs -- norm_num: https://leanprover-community.github.io/mathlib_docs/tactics.html#norm_num -- should we use linarith or omega? -- hint: https://leanprover-community.github.io/mathlib_docs/tactics.html#hint -- classical: https://leanprover-community.github.io/mathlib_docs/tactics.html#classical --/ - -namespace List - - -- TODO: I could not find this function?? - @[simp] def flatten {a : Type u} : List (List a) → List a - | [] => [] - | x :: ls => x ++ flatten ls - -end List - -namespace Lean - -namespace LocalContext - - open Lean Lean.Elab Command Term Lean.Meta - - -- Small utility: return the list of declarations in the context, from - -- the last to the first. - def getAllDecls (lctx : Lean.LocalContext) : MetaM (List Lean.LocalDecl) := - lctx.foldrM (fun d ls => do let d ← instantiateLocalDeclMVars d; pure (d :: ls)) [] - - -- Return the list of declarations in the context, but filter the - -- declarations which are considered as implementation details - def getDecls (lctx : Lean.LocalContext) : MetaM (List Lean.LocalDecl) := do - let ls ← lctx.getAllDecls - pure (ls.filter (fun d => not d.isImplementationDetail)) - -end LocalContext - -end Lean - namespace Arith -open Primitives +open Primitives Utils -- TODO: move? theorem ne_zero_is_lt_or_gt {x : Int} (hne : x ≠ 0) : x < 0 ∨ x > 0 := by diff --git a/backends/lean/Base/Diverge/Base.lean b/backends/lean/Base/Diverge/Base.lean index d2c91ff8..0a9ea4c4 100644 --- a/backends/lean/Base/Diverge/Base.lean +++ b/backends/lean/Base/Diverge/Base.lean @@ -6,28 +6,6 @@ import Mathlib.Tactic.Linarith import Base.Primitives -/- -TODO: -- we want an easier to use cases: - - keeps in the goal an equation of the shape: `t = case` - - if called on Prop terms, uses Classical.em - Actually, the cases from mathlib seems already quite powerful - (https://leanprover-community.github.io/mathlib_docs/tactics.html#cases) - For instance: cases h : e - Also: **casesm** -- better split tactic -- we need conversions to operate on the head of applications. - Actually, something like this works: - ``` - conv at Hl => - apply congr_fun - simp [fix_fuel_P] - ``` - Maybe we need a rpt ... ; focus? -- simplifier/rewriter have a strange behavior sometimes --/ - - /- TODO: this is very useful, but is there more? -/ set_option profiler true set_option profiler.threshold 100 diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index 613f38f8..a288d889 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -60,7 +60,7 @@ section Methods trace[Progress] "Theorem: {th}" -- Dive into the quantified variables and the assumptions forallTelescope th fun fvars th => do - trace[Progress] "All argumens: {fvars}" + trace[Progress] "All arguments: {fvars}" /- -- Filter the argumens which are not propositions let rec getFirstPropIdx (i : Nat) : MetaM Nat := do if i ≥ fargs.size then pure i diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index a4df5c96..b0db465d 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -21,24 +21,11 @@ namespace Test #eval pspecAttr.find? ``Primitives.Vec.index end Test -def progressLookupTheorem (asmTac : TacticM Unit) : TacticM Unit := do - withMainContext do - -- Retrieve the goal - let mgoal ← Tactic.getMainGoal - let goalTy ← mgoal.getType - -- Dive into the goal to lookup the theorem - let (fName, fLevels, args) ← do - withPSpec goalTy fun desc => - -- TODO: check that no universally quantified variables in the arguments - pure (desc.fName, desc.fLevels, desc.args) - -- TODO: also try the assumptions - trace[Progress] "Function: {fName}" - -- TODO: use a list of theorems, and try them one by one? - let thName ← do - match ← pspecAttr.find? fName with - | none => throwError "Could not find a pspec theorem for {fName}" - | some thName => pure thName - trace[Progress] "Lookuped up: {thName}" +inductive TheoremOrLocal where +| Theorem (thName : Name) +| Local (asm : LocalDecl) + +def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) (asmTac : TacticM Unit) : TacticM Unit := do /- Apply the theorem We try to match the theorem with the goal In order to do so, we introduce meta-variables for all the parameters @@ -48,10 +35,14 @@ def progressLookupTheorem (asmTac : TacticM Unit) : TacticM Unit := do quantified). We also make sure that all the meta variables which appear in the function arguments have been instantiated - -/ + -/ let env ← getEnv - let thDecl := env.constants.find! thName - let thTy := thDecl.type + let thTy ← do + match th with + | .Theorem thName => + let thDecl := env.constants.find! thName + pure thDecl.type + | .Local asmDecl => pure asmDecl.type -- TODO: the tactic fails if we uncomment withNewMCtxDepth -- withNewMCtxDepth do let (mvars, binders, thExBody) ← forallMetaTelescope thTy @@ -63,18 +54,19 @@ def progressLookupTheorem (asmTac : TacticM Unit) : TacticM Unit := do -- There shouldn't be any existential variables in thBody pure thBody -- Match the body with the target - let target := mkAppN (.const fName fLevels) args - trace[Progress] "mvars:\n{mvars.map Expr.mvarId!}" - trace[Progress] "thBody: {thBody}" - trace[Progress] "target: {target}" - let ok ← isDefEq thBody target - if ¬ ok then throwError "Could not unify the theorem with the target:\n- theorem: {thBody}\n- target: {target}" + trace[Progress] "Maching `{thBody}` with `{fnExpr}`" + let ok ← isDefEq thBody fnExpr + if ¬ ok then throwError "Could not unify the theorem with the target:\n- theorem: {thBody}\n- target: {fnExpr}" + let mgoal ← Tactic.getMainGoal postprocessAppMVars `progress mgoal mvars binders true true Term.synthesizeSyntheticMVarsNoPostponing let thBody ← instantiateMVars thBody trace[Progress] "thBody (after instantiation): {thBody}" -- Add the instantiated theorem to the assumptions (we apply it on the metavariables). - let th ← mkAppOptM thName (mvars.map some) + let th ← do + match th with + | .Theorem thName => mkAppOptM thName (mvars.map some) + | .Local decl => mkAppOptM' (mkFVar decl.fvarId) (mvars.map some) let asmName ← mkFreshUserName `h let thTy ← inferType th let thAsm ← Utils.addDeclTac asmName th thTy (asLet := false) @@ -112,18 +104,71 @@ def progressLookupTheorem (asmTac : TacticM Unit) : TacticM Unit := do -- pure () -elab "progress" : tactic => do - progressLookupTheorem (firstTac [assumptionTac, Arith.scalarTac]) +-- The array of ids are identifiers to use when introducing fresh variables +def progressAsmsOrLookupTheorem (ids : Array Name) (asmTac : TacticM Unit) : TacticM Unit := do + withMainContext do + -- Retrieve the goal + let mgoal ← Tactic.getMainGoal + let goalTy ← mgoal.getType + -- Dive into the goal to lookup the theorem + let (fName, fLevels, args) ← do + withPSpec goalTy fun desc => + -- TODO: check that no universally quantified variables in the arguments + pure (desc.fName, desc.fLevels, desc.args) + -- TODO: this should be in the pspec desc + let fnExpr := mkAppN (.const fName fLevels) args + trace[Progress] "Function: {fName}" + -- Try all the assumptions one by one and if it fails try to lookup a theorem + let ctx ← Lean.MonadLCtx.getLCtx + let decls ← ctx.getDecls + for decl in decls.reverse do + trace[Progress] "Trying assumption: {decl.userName} : {decl.type}" + try + progressWith fnExpr (.Local decl) ids asmTac + return () + catch _ => continue + -- It failed: try to lookup a theorem + -- TODO: use a list of theorems, and try them one by one? + trace[Progress] "No assumption succeeded: trying to lookup a theorem" + let thName ← do + match ← pspecAttr.find? fName with + | none => throwError "Could not find a pspec theorem for {fName}" + | some thName => pure thName + trace[Progress] "Lookuped up: {thName}" + -- Apply the theorem + progressWith fnExpr (.Theorem thName) ids asmTac + +#check Syntax +syntax progressArgs := ("as" " ⟨ " (ident)+ " ⟩")? + +def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do + let args := args.raw + -- Process the arguments to retrieve the identifiers to use + trace[Progress] "Progressing arguments: {args}" + let args := args.getArgs + let ids := + if args.size > 0 then + let args := (args.get! 0).getArgs + let args := (args.get! 2).getArgs + args.map Syntax.getId + else #[] + trace[Progress] "Ids: {ids}" + --if args[0] ≠ some "as" then throwError "Invalid syntax: should be: `progress as ⟨ ... ⟩`" + progressAsmsOrLookupTheorem ids (firstTac [assumptionTac, Arith.scalarTac]) + +elab "progress" args:progressArgs : tactic => + evalProgress args namespace Test open Primitives set_option trace.Progress true + set_option pp.rawOnError true @[pspec] theorem vec_index_test2 (α : Type u) (v: Vec α) (i: Usize) (h: i.val < v.val.length) : ∃ (x: α), v.index α i = .ret x := by - progress + progress as ⟨ x y z ⟩ simp set_option trace.Progress false diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index 14feb567..505412b9 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -2,6 +2,68 @@ import Lean import Mathlib.Tactic.Core import Mathlib.Tactic.LeftRight +/- +Mathlib tactics: +- rcases: https://leanprover-community.github.io/mathlib_docs/tactics.html#rcases +- split_ifs: https://leanprover-community.github.io/mathlib_docs/tactics.html#split_ifs +- norm_num: https://leanprover-community.github.io/mathlib_docs/tactics.html#norm_num +- should we use linarith or omega? +- hint: https://leanprover-community.github.io/mathlib_docs/tactics.html#hint +- classical: https://leanprover-community.github.io/mathlib_docs/tactics.html#classical +-/ + +/- +TODO: +- we want an easier to use cases: + - keeps in the goal an equation of the shape: `t = case` + - if called on Prop terms, uses Classical.em + Actually, the cases from mathlib seems already quite powerful + (https://leanprover-community.github.io/mathlib_docs/tactics.html#cases) + For instance: cases h : e + Also: **casesm** +- better split tactic +- we need conversions to operate on the head of applications. + Actually, something like this works: + ``` + conv at Hl => + apply congr_fun + simp [fix_fuel_P] + ``` + Maybe we need a rpt ... ; focus? +- simplifier/rewriter have a strange behavior sometimes +-/ + + +namespace List + + -- TODO: I could not find this function?? + @[simp] def flatten {a : Type u} : List (List a) → List a + | [] => [] + | x :: ls => x ++ flatten ls + +end List + +namespace Lean + +namespace LocalContext + + open Lean Lean.Elab Command Term Lean.Meta + + -- Small utility: return the list of declarations in the context, from + -- the last to the first. + def getAllDecls (lctx : Lean.LocalContext) : MetaM (List Lean.LocalDecl) := + lctx.foldrM (fun d ls => do let d ← instantiateLocalDeclMVars d; pure (d :: ls)) [] + + -- Return the list of declarations in the context, but filter the + -- declarations which are considered as implementation details + def getDecls (lctx : Lean.LocalContext) : MetaM (List Lean.LocalDecl) := do + let ls ← lctx.getAllDecls + pure (ls.filter (fun d => not d.isImplementationDetail)) + +end LocalContext + +end Lean + namespace Utils open Lean Elab Term Meta Tactic -- cgit v1.3.1 From 6cc0279045d40231f1cce83f0edb7aada1e59d92 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 13 Jul 2023 10:37:16 +0200 Subject: Finish implementing the syntax for `progress` --- backends/lean/Base/Progress/Progress.lean | 98 ++++++++++++++++++++++--------- backends/lean/Base/Utils.lean | 47 +++++++++++---- 2 files changed, 107 insertions(+), 38 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index b0db465d..835dc468 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -25,7 +25,17 @@ inductive TheoremOrLocal where | Theorem (thName : Name) | Local (asm : LocalDecl) -def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) (asmTac : TacticM Unit) : TacticM Unit := do +/- Type to propagate the errors of `progressWith`. + We need this because we use the exceptions to backtrack, when trying to + use the assumptions for instance. When there is actually an error we want + to propagate to the user, we return it. -/ +inductive ProgressError +| Ok +| Error (msg : MessageData) +deriving Inhabited + +def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) + (asmTac : TacticM Unit) : TacticM ProgressError := do /- Apply the theorem We try to match the theorem with the goal In order to do so, we introduce meta-variables for all the parameters @@ -77,32 +87,62 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) (asmTa -- The assumption should be of the shape: -- `∃ x1 ... xn, f args = ... ∧ ...` -- We introduce the existentially quantified variables and split the top-most - -- conjunction if there is one - splitAllExistsTac thAsm fun h => do - -- Split the conjunction - let splitConj (k : Expr → TacticM Unit) : TacticM Unit := do - if ← isConj (← inferType h) then - splitConjTac h (fun h _ => k h) - else k h - -- Simplify the target by using the equality and some monad simplifications - splitConj fun h => do + -- conjunction if there is one. We use the provided `ids` list to name the + -- introduced variables. + let res ← splitAllExistsTac thAsm ids.toList fun h ids => do + -- Split the conjunctions. + -- For the conjunctions, we split according once to separate the equality `f ... = .ret ...` + -- from the postcondition, if there is, then continue to split the postcondition if there + -- are remaining ids. + let splitEqAndPost (k : Expr → Option Expr → List Name → TacticM ProgressError) : TacticM ProgressError := do + if ← isConj (← inferType h) then do + let hName := (← h.fvarId!.getDecl).userName + let (optId, ids) := listTryPopHead ids + let optIds := match optId with | none => none | some id => some (hName, id) + splitConjTac h optIds (fun hEq hPost => k hEq (some hPost) ids) + else k h none ids + -- Simplify the target by using the equality and some monad simplifications, + -- 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] - [h.fvarId!] (.targets #[] true) + [hEq.fvarId!] (.targets #[] true) -- Clear the equality let mgoal ← getMainGoal - let mgoal ← mgoal.tryClearMany #[h.fvarId!] + let mgoal ← mgoal.tryClearMany #[hEq.fvarId!] setGoals (mgoal :: (← getUnsolvedGoals)) - -- Update the set of goals - let curGoals ← getUnsolvedGoals - let newGoals := mvars.map Expr.mvarId! - let newGoals ← newGoals.filterM fun mvar => not <$> mvar.isAssigned - trace[Progress] "new goals: {newGoals}" - setGoals newGoals.toList - allGoals asmTac - let newGoals ← getUnsolvedGoals - setGoals (newGoals ++ curGoals) - -- - pure () + trace[Progress] "Goal after splitting eq and post and simplifying the target: {mgoal}" + -- Continue splitting following the ids provided by the user + if ¬ ids.isEmpty then + let hPost ← + match hPost with + | none => do return (.Error m!"Too many ids provided ({ids}): there is no postcondition to split") + | some hPost => pure hPost + let curPostId := (← hPost.fvarId!.getDecl).userName + let rec splitPost (hPost : Expr) (ids : List Name) : TacticM ProgressError := do + match ids with + | [] => pure .Ok -- Stop + | nid :: ids => do + -- Split + if ← isConj hPost then + splitConjTac hPost (some (nid, curPostId)) (λ _ nhPost => splitPost nhPost ids) + else return (.Error m!"Too many ids provided ({nid :: ids}) not enough conjuncts to split in the postcondition") + splitPost hPost ids + else return .Ok + match res with + | .Error _ => return res -- Can we get there? We're using "return" + | .Ok => + -- Update the set of goals + let curGoals ← getUnsolvedGoals + let newGoals := mvars.map Expr.mvarId! + let newGoals ← newGoals.filterM fun mvar => not <$> mvar.isAssigned + trace[Progress] "new goals: {newGoals}" + setGoals newGoals.toList + allGoals asmTac + let newGoals ← getUnsolvedGoals + setGoals (newGoals ++ curGoals) + -- + pure .Ok -- The array of ids are identifiers to use when introducing fresh variables def progressAsmsOrLookupTheorem (ids : Array Name) (asmTac : TacticM Unit) : TacticM Unit := do @@ -124,8 +164,9 @@ def progressAsmsOrLookupTheorem (ids : Array Name) (asmTac : TacticM Unit) : Tac for decl in decls.reverse do trace[Progress] "Trying assumption: {decl.userName} : {decl.type}" try - progressWith fnExpr (.Local decl) ids asmTac - return () + match ← progressWith fnExpr (.Local decl) ids asmTac with + | .Ok => return () + | .Error msg => throwError msg catch _ => continue -- It failed: try to lookup a theorem -- TODO: use a list of theorems, and try them one by one? @@ -136,9 +177,10 @@ def progressAsmsOrLookupTheorem (ids : Array Name) (asmTac : TacticM Unit) : Tac | some thName => pure thName trace[Progress] "Lookuped up: {thName}" -- Apply the theorem - progressWith fnExpr (.Theorem thName) ids asmTac + match ← progressWith fnExpr (.Theorem thName) ids asmTac with + | .Ok => return () + | .Error msg => throwError msg -#check Syntax syntax progressArgs := ("as" " ⟨ " (ident)+ " ⟩")? def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do @@ -168,7 +210,7 @@ namespace Test @[pspec] theorem vec_index_test2 (α : Type u) (v: Vec α) (i: Usize) (h: i.val < v.val.length) : ∃ (x: α), v.index α i = .ret x := by - progress as ⟨ x y z ⟩ + progress as ⟨ x ⟩ simp set_option trace.Progress false diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index 505412b9..599c3a9f 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -396,13 +396,21 @@ example (x y : Int) (h0 : x ≤ y ∨ x ≥ y) : x ≤ y ∨ x ≥ y := by . right; assumption --- Tactic to split on an exists -def splitExistsTac (h : Expr) (k : Expr → Expr → TacticM α) : TacticM α := do +-- Tactic to split on an exists. +-- `h` must be an FVar +def splitExistsTac (h : Expr) (optId : Option Name) (k : Expr → Expr → TacticM α) : TacticM α := do withMainContext do let goal ← getMainGoal let hTy ← inferType h if isExists hTy then do - let newGoals ← goal.cases h.fvarId! #[] + -- Try to use the user-provided names + let altVarNames ← + match optId with + | none => pure #[] + | some id => do + let hDecl ← h.fvarId!.getDecl + pure #[{ varNames := [id, hDecl.userName] }] + let newGoals ← goal.cases h.fvarId! altVarNames -- There should be exactly one goal match newGoals.toList with | [ newGoal ] => @@ -418,18 +426,37 @@ def splitExistsTac (h : Expr) (k : Expr → Expr → TacticM α) : TacticM α := else throwError "Not a conjunction" -partial def splitAllExistsTac [Inhabited α] (h : Expr) (k : Expr → TacticM α) : TacticM α := do +-- TODO: move +def listTryPopHead (ls : List α) : Option α × List α := + match ls with + | [] => (none, ls) + | hd :: tl => (some hd, tl) + +/- Destruct all the existentials appearing in `h`, and introduce them as variables + in the context. + + If `ids` is not empty, we use it to name the introduced variables. We + transmit the stripped expression and the remaining ids to the continuation. + -/ +partial def splitAllExistsTac [Inhabited α] (h : Expr) (ids : List Name) (k : Expr → List Name → TacticM α) : TacticM α := do try - splitExistsTac h (fun _ body => splitAllExistsTac body k) - catch _ => k h + let (optId, ids) := listTryPopHead ids + splitExistsTac h optId (fun _ body => splitAllExistsTac body ids k) + catch _ => k h ids -- Tactic to split on a conjunction. -def splitConjTac (h : Expr) (k : Expr → Expr → TacticM α) : TacticM α := do +def splitConjTac (h : Expr) (optIds : Option (Name × Name)) (k : Expr → Expr → TacticM α) : TacticM α := do withMainContext do let goal ← getMainGoal let hTy ← inferType h if ← isConj hTy then do - let newGoals ← goal.cases h.fvarId! #[] + -- Try to use the user-provided names + let altVarNames ← + match optIds with + | none => pure #[] + | some (id0, id1) => do + pure #[{ varNames := [id0, id1] }] + let newGoals ← goal.cases h.fvarId! altVarNames -- There should be exactly one goal match newGoals.toList with | [ newGoal ] => @@ -449,13 +476,13 @@ elab "split_conj " n:ident : tactic => do withMainContext do let decl ← Lean.Meta.getLocalDeclFromUserName n.getId let fvar := mkFVar decl.fvarId - splitConjTac fvar (fun _ _ => pure ()) + splitConjTac fvar none (fun _ _ => pure ()) elab "split_all_exists " n:ident : tactic => do withMainContext do let decl ← Lean.Meta.getLocalDeclFromUserName n.getId let fvar := mkFVar decl.fvarId - splitAllExistsTac fvar (fun _ => pure ()) + splitAllExistsTac fvar [] (fun _ _ => pure ()) example (h : a ∧ b) : a := by split_all_exists h -- cgit v1.3.1 From 4f7ebc2358d78d31d63a609a32e5a732b82d468e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 17 Jul 2023 12:12:34 +0200 Subject: Update the lean dependencies and update IList --- backends/lean/Base.lean | 1 + backends/lean/Base/IList.lean | 1 - backends/lean/Base/Progress/Progress.lean | 3 --- backends/lean/lake-manifest.json | 14 ++++++++++---- backends/lean/lean-toolchain | 2 +- tests/lean/lake-manifest.json | 8 ++++---- tests/lean/lean-toolchain | 2 +- 7 files changed, 17 insertions(+), 14 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base.lean b/backends/lean/Base.lean index 51211704..2077d410 100644 --- a/backends/lean/Base.lean +++ b/backends/lean/Base.lean @@ -3,3 +3,4 @@ import Base.Primitives import Base.Diverge import Base.Arith import Base.Progress +import Base.IList diff --git a/backends/lean/Base/IList.lean b/backends/lean/Base/IList.lean index 7e764d63..3db00cbb 100644 --- a/backends/lean/Base/IList.lean +++ b/backends/lean/Base/IList.lean @@ -7,7 +7,6 @@ import Base.Arith namespace List -#check List.get def len (ls : List α) : Int := match ls with | [] => 0 diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 835dc468..35a3c25a 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -15,7 +15,6 @@ namespace Test @[pspec] theorem vec_index_test (α : Type u) (v: Vec α) (i: Usize) (h: i.val < v.val.length) : ∃ x, v.index α i = .ret x := by - apply sorry #eval pspecAttr.find? ``Primitives.Vec.index @@ -195,7 +194,6 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do args.map Syntax.getId else #[] trace[Progress] "Ids: {ids}" - --if args[0] ≠ some "as" then throwError "Invalid syntax: should be: `progress as ⟨ ... ⟩`" progressAsmsOrLookupTheorem ids (firstTac [assumptionTac, Arith.scalarTac]) elab "progress" args:progressArgs : tactic => @@ -205,7 +203,6 @@ namespace Test open Primitives set_option trace.Progress true - set_option pp.rawOnError true @[pspec] theorem vec_index_test2 (α : Type u) (v: Vec α) (i: Usize) (h: i.val < v.val.length) : diff --git a/backends/lean/lake-manifest.json b/backends/lean/lake-manifest.json index f4759ad3..5a089838 100644 --- a/backends/lean/lake-manifest.json +++ b/backends/lean/lake-manifest.json @@ -7,27 +7,33 @@ "rev": "c43db94a8f495dad37829e9d7ad65483d68c86b8", "name": "proofwidgets", "inputRev?": "v0.0.11"}}, + {"git": + {"url": "https://github.com/mhuisi/lean4-cli.git", + "subDir?": null, + "rev": "5a858c32963b6b19be0d477a30a1f4b6c120be7e", + "name": "Cli", + "inputRev?": "nightly"}}, {"git": {"url": "https://github.com/leanprover-community/mathlib4.git", "subDir?": null, - "rev": "cc5d11f24e1b92db65ec3389bb5142f4b2d7670e", + "rev": "fa05951a270fef2873666c46f138e90338cd48d6", "name": "mathlib", "inputRev?": null}}, {"git": {"url": "https://github.com/gebner/quote4", "subDir?": null, - "rev": "c71f94e34c1cda52eef5c93dc9da409ab2727420", + "rev": "c0d9516f44d07feee01c1103c8f2f7c24a822b55", "name": "Qq", "inputRev?": "master"}}, {"git": {"url": "https://github.com/JLimperg/aesop", "subDir?": null, - "rev": "ca73109cc40837bc61df8024c9016da4b4f99d4c", + "rev": "f04538ab6ad07642368cf11d2702acc0a9b4bcee", "name": "aesop", "inputRev?": "master"}}, {"git": {"url": "https://github.com/leanprover/std4", "subDir?": null, - "rev": "e68aa8f5fe47aad78987df45f99094afbcb5e936", + "rev": "dff883c55395438ae2a5c65ad5ddba084b600feb", "name": "std", "inputRev?": "main"}}]} diff --git a/backends/lean/lean-toolchain b/backends/lean/lean-toolchain index 42e7d786..334c5053 100644 --- a/backends/lean/lean-toolchain +++ b/backends/lean/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:nightly-2023-06-20 \ No newline at end of file +leanprover/lean4:nightly-2023-07-12 \ No newline at end of file diff --git a/tests/lean/lake-manifest.json b/tests/lean/lake-manifest.json index 8bbfb7cd..94030cb6 100644 --- a/tests/lean/lake-manifest.json +++ b/tests/lean/lake-manifest.json @@ -17,24 +17,24 @@ {"git": {"url": "https://github.com/leanprover-community/mathlib4.git", "subDir?": null, - "rev": "82fe7e902b01fe686b91c19550f1e228ad2dec1c", + "rev": "fa05951a270fef2873666c46f138e90338cd48d6", "name": "mathlib", "inputRev?": null}}, {"git": {"url": "https://github.com/gebner/quote4", "subDir?": null, - "rev": "c71f94e34c1cda52eef5c93dc9da409ab2727420", + "rev": "c0d9516f44d07feee01c1103c8f2f7c24a822b55", "name": "Qq", "inputRev?": "master"}}, {"git": {"url": "https://github.com/JLimperg/aesop", "subDir?": null, - "rev": "ca73109cc40837bc61df8024c9016da4b4f99d4c", + "rev": "f04538ab6ad07642368cf11d2702acc0a9b4bcee", "name": "aesop", "inputRev?": "master"}}, {"git": {"url": "https://github.com/leanprover/std4", "subDir?": null, - "rev": "e68aa8f5fe47aad78987df45f99094afbcb5e936", + "rev": "dff883c55395438ae2a5c65ad5ddba084b600feb", "name": "std", "inputRev?": "main"}}]} diff --git a/tests/lean/lean-toolchain b/tests/lean/lean-toolchain index 42e7d786..334c5053 100644 --- a/tests/lean/lean-toolchain +++ b/tests/lean/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:nightly-2023-06-20 \ No newline at end of file +leanprover/lean4:nightly-2023-07-12 \ No newline at end of file -- cgit v1.3.1 From 3e8060b5501ec83940a4309389a68898df26ebd0 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 17 Jul 2023 23:37:31 +0200 Subject: Reorganize the Lean backend --- backends/lean/Base/Arith.lean | 3 +- backends/lean/Base/Arith/Arith.lean | 329 -------------- backends/lean/Base/Arith/Int.lean | 236 ++++++++++ backends/lean/Base/Arith/Scalar.lean | 48 ++ backends/lean/Base/IList.lean | 127 +----- backends/lean/Base/IList/IList.lean | 142 ++++++ backends/lean/Base/Primitives.lean | 718 +----------------------------- backends/lean/Base/Primitives/Base.lean | 130 ++++++ backends/lean/Base/Primitives/Scalar.lean | 507 +++++++++++++++++++++ backends/lean/Base/Primitives/Vec.lean | 113 +++++ backends/lean/Base/Progress/Progress.lean | 2 + 11 files changed, 1184 insertions(+), 1171 deletions(-) create mode 100644 backends/lean/Base/Arith/Int.lean create mode 100644 backends/lean/Base/Arith/Scalar.lean create mode 100644 backends/lean/Base/IList/IList.lean create mode 100644 backends/lean/Base/Primitives/Base.lean create mode 100644 backends/lean/Base/Primitives/Scalar.lean create mode 100644 backends/lean/Base/Primitives/Vec.lean (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Arith.lean b/backends/lean/Base/Arith.lean index fd5698c5..c0d09fd2 100644 --- a/backends/lean/Base/Arith.lean +++ b/backends/lean/Base/Arith.lean @@ -1 +1,2 @@ -import Base.Arith.Arith +import Base.Arith.Int +import Base.Arith.Scalar diff --git a/backends/lean/Base/Arith/Arith.lean b/backends/lean/Base/Arith/Arith.lean index da263e86..e69de29b 100644 --- a/backends/lean/Base/Arith/Arith.lean +++ b/backends/lean/Base/Arith/Arith.lean @@ -1,329 +0,0 @@ -/- This file contains tactics to solve arithmetic goals -/ - -import Lean -import Lean.Meta.Tactic.Simp -import Init.Data.List.Basic -import Mathlib.Tactic.RunCmd -import Mathlib.Tactic.Linarith --- TODO: there is no Omega tactic for now - it seems it hasn't been ported yet ---import Mathlib.Tactic.Omega -import Base.Primitives -import Base.Utils -import Base.Arith.Base - -namespace Arith - -open Primitives Utils - --- TODO: move -/- Remark: we can't write the following instance because of restrictions about - the type class parameters (`ty` doesn't appear in the return type, which is - forbidden): - - ``` - instance Scalar.cast (ty : ScalarTy) : Coe (Scalar ty) Int where coe := λ v => v.val - ``` - -/ -def Scalar.toInt {ty : ScalarTy} (x : Scalar ty) : Int := x.val - --- Remark: I tried a version of the shape `HasScalarProp {a : Type} (x : a)` --- but the lookup didn't work -class HasScalarProp (a : Sort u) where - prop_ty : a → Prop - prop : ∀ x:a, prop_ty x - -class HasIntProp (a : Sort u) where - prop_ty : a → Prop - prop : ∀ x:a, prop_ty x - -instance (ty : ScalarTy) : HasScalarProp (Scalar ty) where - -- prop_ty is inferred - prop := λ x => And.intro x.hmin x.hmax - -instance (a : Type) : HasScalarProp (Vec a) where - prop_ty := λ v => v.val.length ≤ Scalar.max ScalarTy.Usize - prop := λ ⟨ _, l ⟩ => l - -class PropHasImp (x : Prop) where - concl : Prop - prop : x → concl - --- This also works for `x ≠ y` because this expression reduces to `¬ x = y` --- and `Ne` is marked as `reducible` -instance (x y : Int) : PropHasImp (¬ x = y) where - concl := x < y ∨ x > y - prop := λ (h:x ≠ y) => ne_is_lt_or_gt h - -open Lean Lean.Elab Command Term Lean.Meta - --- Small utility: print all the declarations in the context -elab "print_all_decls" : tactic => do - let ctx ← Lean.MonadLCtx.getLCtx - for decl in ← ctx.getDecls do - let ty ← Lean.Meta.inferType decl.toExpr - logInfo m!"{decl.toExpr} : {ty}" - pure () - --- Explore a term by decomposing the applications (we explore the applied --- functions and their arguments, but ignore lambdas, forall, etc. - --- should we go inside?). -partial def foldTermApps (k : α → Expr → MetaM α) (s : α) (e : Expr) : MetaM α := do - -- We do it in a very simpler manner: we deconstruct applications, - -- and recursively explore the sub-expressions. Note that we do - -- not go inside foralls and abstractions (should we?). - e.withApp fun f args => do - let s ← k s f - args.foldlM (foldTermApps k) s - --- Provided a function `k` which lookups type class instances on an expression, --- collect all the instances lookuped by applying `k` on the sub-expressions of `e`. -def collectInstances - (k : Expr → MetaM (Option Expr)) (s : HashSet Expr) (e : Expr) : MetaM (HashSet Expr) := do - let k s e := do - match ← k e with - | none => pure s - | some i => pure (s.insert i) - foldTermApps k s e - --- Similar to `collectInstances`, but explores all the local declarations in the --- main context. -def collectInstancesFromMainCtx (k : Expr → MetaM (Option Expr)) : Tactic.TacticM (HashSet Expr) := do - Tactic.withMainContext do - -- Get the local context - let ctx ← Lean.MonadLCtx.getLCtx - -- Just a matter of precaution - let ctx ← instantiateLCtxMVars ctx - -- Initialize the hashset - let hs := HashSet.empty - -- Explore the declarations - let decls ← ctx.getDecls - decls.foldlM (fun hs d => collectInstances k hs d.toExpr) hs - --- Helper -def lookupProp (fName : String) (className : Name) (e : Expr) : MetaM (Option Expr) := do - trace[Arith] fName - -- TODO: do we need Lean.observing? - -- This actually eliminates the error messages - Lean.observing? do - trace[Arith] m!"{fName}: observing" - let ty ← Lean.Meta.inferType e - let hasProp ← mkAppM className #[ty] - let hasPropInst ← trySynthInstance hasProp - match hasPropInst with - | LOption.some i => - trace[Arith] "Found HasScalarProp instance" - let i_prop ← mkProjection i (Name.mkSimple "prop") - some (← mkAppM' i_prop #[e]) - | _ => none - --- Return an instance of `HasIntProp` for `e` if it has some -def lookupHasIntProp (e : Expr) : MetaM (Option Expr) := - lookupProp "lookupHasScalarProp" ``HasIntProp e - --- Return an instance of `HasScalarProp` for `e` if it has some -def lookupHasScalarProp (e : Expr) : MetaM (Option Expr) := - lookupProp "lookupHasScalarProp" ``HasScalarProp e - --- Collect the instances of `HasIntProp` for the subexpressions in the context -def collectHasIntPropInstancesFromMainCtx : Tactic.TacticM (HashSet Expr) := do - collectInstancesFromMainCtx lookupHasIntProp - --- Collect the instances of `HasScalarProp` for the subexpressions in the context -def collectHasScalarPropInstancesFromMainCtx : Tactic.TacticM (HashSet Expr) := do - collectInstancesFromMainCtx lookupHasScalarProp - -elab "display_has_prop_instances" : tactic => do - trace[Arith] "Displaying the HasScalarProp instances" - let hs ← collectHasScalarPropInstancesFromMainCtx - hs.forM fun e => do - trace[Arith] "+ HasScalarProp instance: {e}" - -example (x : U32) : True := by - let i : HasScalarProp U32 := inferInstance - have p := @HasScalarProp.prop _ i x - simp only [HasScalarProp.prop_ty] at p - display_has_prop_instances - simp - --- Return an instance of `PropHasImp` for `e` if it has some -def lookupPropHasImp (e : Expr) : MetaM (Option Expr) := do - trace[Arith] "lookupPropHasImp" - -- TODO: do we need Lean.observing? - -- This actually eliminates the error messages - Lean.observing? do - trace[Arith] "lookupPropHasImp: observing" - let ty ← Lean.Meta.inferType e - trace[Arith] "lookupPropHasImp: ty: {ty}" - let cl ← mkAppM ``PropHasImp #[ty] - let inst ← trySynthInstance cl - match inst with - | LOption.some i => - trace[Arith] "Found PropHasImp instance" - let i_prop ← mkProjection i (Name.mkSimple "prop") - some (← mkAppM' i_prop #[e]) - | _ => none - --- Collect the instances of `PropHasImp` for the subexpressions in the context -def collectPropHasImpInstancesFromMainCtx : Tactic.TacticM (HashSet Expr) := do - collectInstancesFromMainCtx lookupPropHasImp - -elab "display_prop_has_imp_instances" : tactic => do - trace[Arith] "Displaying the PropHasImp instances" - let hs ← collectPropHasImpInstancesFromMainCtx - hs.forM fun e => do - trace[Arith] "+ PropHasImp instance: {e}" - -example (x y : Int) (_ : x ≠ y) (_ : ¬ x = y) : True := by - display_prop_has_imp_instances - simp - --- Lookup instances in a context and introduce them with additional declarations. -def introInstances (declToUnfold : Name) (lookup : Expr → MetaM (Option Expr)) : Tactic.TacticM (Array Expr) := do - let hs ← collectInstancesFromMainCtx lookup - hs.toArray.mapM fun e => do - let type ← inferType e - let name ← mkFreshUserName `h - -- Add a declaration - let nval ← Utils.addDeclTac name e type (asLet := false) - -- Simplify to unfold the declaration to unfold (i.e., the projector) - Utils.simpAt [declToUnfold] [] [] (Tactic.Location.targets #[mkIdent name] false) - -- Return the new value - pure nval - -def introHasIntPropInstances : Tactic.TacticM (Array Expr) := do - trace[Arith] "Introducing the HasIntProp instances" - introInstances ``HasIntProp.prop_ty lookupHasIntProp - -def introHasScalarPropInstances : Tactic.TacticM (Array Expr) := do - trace[Arith] "Introducing the HasScalarProp instances" - introInstances ``HasScalarProp.prop_ty lookupHasScalarProp - --- Lookup the instances of `HasScalarProp for all the sub-expressions in the context, --- and introduce the corresponding assumptions -elab "intro_has_prop_instances" : tactic => do - let _ ← introHasScalarPropInstances - -example (x y : U32) : x.val ≤ Scalar.max ScalarTy.U32 := by - intro_has_prop_instances - simp [*] - -example {a: Type} (v : Vec a) : v.val.length ≤ Scalar.max ScalarTy.Usize := by - intro_has_prop_instances - simp_all [Scalar.max, Scalar.min] - --- Lookup the instances of `PropHasImp for all the sub-expressions in the context, --- and introduce the corresponding assumptions -elab "intro_prop_has_imp_instances" : tactic => do - trace[Arith] "Introducing the PropHasImp instances" - let _ ← introInstances ``PropHasImp.concl lookupPropHasImp - -example (x y : Int) (h0 : x ≤ y) (h1 : x ≠ y) : x < y := by - intro_prop_has_imp_instances - rename_i h - split_disj h - . linarith - . linarith - -/- Boosting a bit the linarith tac. - - We do the following: - - for all the assumptions of the shape `(x : Int) ≠ y` or `¬ (x = y), we - introduce two goals with the assumptions `x < y` and `x > y` - TODO: we could create a PR for mathlib. - -/ -def intTacPreprocess : Tactic.TacticM Unit := do - Tactic.withMainContext do - -- Lookup the instances of PropHasImp (this is how we detect assumptions - -- of the proper shape), introduce assumptions in the context and split - -- on those - -- TODO: get rid of the assumptions that we split - let rec splitOnAsms (asms : List Expr) : Tactic.TacticM Unit := - match asms with - | [] => pure () - | asm :: asms => - let k := splitOnAsms asms - Utils.splitDisjTac asm k k - -- Introduce - let _ ← introHasIntPropInstances - let asms ← introInstances ``PropHasImp.concl lookupPropHasImp - -- Split - splitOnAsms asms.toList - -elab "int_tac_preprocess" : tactic => - intTacPreprocess - -def intTac : Tactic.TacticM Unit := do - Tactic.withMainContext do - Tactic.focus do - -- Preprocess - wondering if we should do this before or after splitting - -- the goal. I think before leads to a smaller proof term? - Tactic.allGoals intTacPreprocess - -- Split the conjunctions in the goal - Utils.repeatTac Utils.splitConjTarget - -- Call linarith - let linarith := - let cfg : Linarith.LinarithConfig := { - -- We do this with our custom preprocessing - splitNe := false - } - Tactic.liftMetaFinishingTactic <| Linarith.linarith false [] cfg - Tactic.allGoals linarith - -elab "int_tac" : tactic => - intTac - -example (x : Int) (h0: 0 ≤ x) (h1: x ≠ 0) : 0 < x := by - int_tac_preprocess - linarith - linarith - -example (x : Int) (h0: 0 ≤ x) (h1: x ≠ 0) : 0 < x := by - int_tac - --- Checking that things append correctly when there are several disjunctions -example (x y : Int) (h0: 0 ≤ x) (h1: x ≠ 0) (h2 : 0 ≤ y) (h3 : y ≠ 0) : 0 < x ∧ 0 < y := by - int_tac - --- Checking that things append correctly when there are several disjunctions -example (x y : Int) (h0: 0 ≤ x) (h1: x ≠ 0) (h2 : 0 ≤ y) (h3 : y ≠ 0) : 0 < x ∧ 0 < y ∧ x + y ≥ 2 := by - int_tac - -def scalarTacPreprocess (tac : Tactic.TacticM Unit) : Tactic.TacticM Unit := do - Tactic.withMainContext do - -- Introduce the scalar bounds - let _ ← introHasScalarPropInstances - Tactic.allGoals do - -- Inroduce the bounds for the isize/usize types - let add (e : Expr) : Tactic.TacticM Unit := do - let ty ← inferType e - let _ ← Utils.addDeclTac (← mkFreshUserName `h) e ty (asLet := false) - add (← mkAppM ``Scalar.cMin_bound #[.const ``ScalarTy.Isize []]) - add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Usize []]) - add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Isize []]) - -- Reveal the concrete bounds - Utils.simpAt [``Scalar.min, ``Scalar.max, ``Scalar.cMin, ``Scalar.cMax, - ``I8.min, ``I16.min, ``I32.min, ``I64.min, ``I128.min, - ``I8.max, ``I16.max, ``I32.max, ``I64.max, ``I128.max, - ``U8.min, ``U16.min, ``U32.min, ``U64.min, ``U128.min, - ``U8.max, ``U16.max, ``U32.max, ``U64.max, ``U128.max - ] [] [] .wildcard - -- Finish the proof - tac - -elab "scalar_tac_preprocess" : tactic => - scalarTacPreprocess intTacPreprocess - --- A tactic to solve linear arithmetic goals in the presence of scalars -def scalarTac : Tactic.TacticM Unit := do - scalarTacPreprocess intTac - -elab "scalar_tac" : tactic => - scalarTac - -example (x y : U32) : x.val ≤ Scalar.max ScalarTy.U32 := by - scalar_tac - -example {a: Type} (v : Vec a) : v.val.length ≤ Scalar.max ScalarTy.Usize := by - scalar_tac - -end Arith diff --git a/backends/lean/Base/Arith/Int.lean b/backends/lean/Base/Arith/Int.lean new file mode 100644 index 00000000..5f00ab52 --- /dev/null +++ b/backends/lean/Base/Arith/Int.lean @@ -0,0 +1,236 @@ +/- This file contains tactics to solve arithmetic goals -/ + +import Lean +import Lean.Meta.Tactic.Simp +import Init.Data.List.Basic +import Mathlib.Tactic.RunCmd +import Mathlib.Tactic.Linarith +-- TODO: there is no Omega tactic for now - it seems it hasn't been ported yet +--import Mathlib.Tactic.Omega +import Base.Utils +import Base.Arith.Base + +namespace Arith + +open Utils + +-- Remark: I tried a version of the shape `HasScalarProp {a : Type} (x : a)` +-- but the lookup didn't work +class HasIntProp (a : Sort u) where + prop_ty : a → Prop + prop : ∀ x:a, prop_ty x + +class PropHasImp (x : Prop) where + concl : Prop + prop : x → concl + +-- This also works for `x ≠ y` because this expression reduces to `¬ x = y` +-- and `Ne` is marked as `reducible` +instance (x y : Int) : PropHasImp (¬ x = y) where + concl := x < y ∨ x > y + prop := λ (h:x ≠ y) => ne_is_lt_or_gt h + +open Lean Lean.Elab Lean.Meta + +-- Small utility: print all the declarations in the context +elab "print_all_decls" : tactic => do + let ctx ← Lean.MonadLCtx.getLCtx + for decl in ← ctx.getDecls do + let ty ← Lean.Meta.inferType decl.toExpr + logInfo m!"{decl.toExpr} : {ty}" + pure () + +-- Explore a term by decomposing the applications (we explore the applied +-- functions and their arguments, but ignore lambdas, forall, etc. - +-- should we go inside?). +partial def foldTermApps (k : α → Expr → MetaM α) (s : α) (e : Expr) : MetaM α := do + -- We do it in a very simpler manner: we deconstruct applications, + -- and recursively explore the sub-expressions. Note that we do + -- not go inside foralls and abstractions (should we?). + e.withApp fun f args => do + let s ← k s f + args.foldlM (foldTermApps k) s + +-- Provided a function `k` which lookups type class instances on an expression, +-- collect all the instances lookuped by applying `k` on the sub-expressions of `e`. +def collectInstances + (k : Expr → MetaM (Option Expr)) (s : HashSet Expr) (e : Expr) : MetaM (HashSet Expr) := do + let k s e := do + match ← k e with + | none => pure s + | some i => pure (s.insert i) + foldTermApps k s e + +-- Similar to `collectInstances`, but explores all the local declarations in the +-- main context. +def collectInstancesFromMainCtx (k : Expr → MetaM (Option Expr)) : Tactic.TacticM (HashSet Expr) := do + Tactic.withMainContext do + -- Get the local context + let ctx ← Lean.MonadLCtx.getLCtx + -- Just a matter of precaution + let ctx ← instantiateLCtxMVars ctx + -- Initialize the hashset + let hs := HashSet.empty + -- Explore the declarations + let decls ← ctx.getDecls + decls.foldlM (fun hs d => collectInstances k hs d.toExpr) hs + +-- Helper +def lookupProp (fName : String) (className : Name) (e : Expr) : MetaM (Option Expr) := do + trace[Arith] fName + -- TODO: do we need Lean.observing? + -- This actually eliminates the error messages + Lean.observing? do + trace[Arith] m!"{fName}: observing" + let ty ← Lean.Meta.inferType e + let hasProp ← mkAppM className #[ty] + let hasPropInst ← trySynthInstance hasProp + match hasPropInst with + | LOption.some i => + trace[Arith] "Found {fName} instance" + let i_prop ← mkProjection i (Name.mkSimple "prop") + some (← mkAppM' i_prop #[e]) + | _ => none + +-- Return an instance of `HasIntProp` for `e` if it has some +def lookupHasIntProp (e : Expr) : MetaM (Option Expr) := + lookupProp "lookupHasIntProp" ``HasIntProp e + +-- Collect the instances of `HasIntProp` for the subexpressions in the context +def collectHasIntPropInstancesFromMainCtx : Tactic.TacticM (HashSet Expr) := do + collectInstancesFromMainCtx lookupHasIntProp + +-- Return an instance of `PropHasImp` for `e` if it has some +def lookupPropHasImp (e : Expr) : MetaM (Option Expr) := do + trace[Arith] "lookupPropHasImp" + -- TODO: do we need Lean.observing? + -- This actually eliminates the error messages + Lean.observing? do + trace[Arith] "lookupPropHasImp: observing" + let ty ← Lean.Meta.inferType e + trace[Arith] "lookupPropHasImp: ty: {ty}" + let cl ← mkAppM ``PropHasImp #[ty] + let inst ← trySynthInstance cl + match inst with + | LOption.some i => + trace[Arith] "Found PropHasImp instance" + let i_prop ← mkProjection i (Name.mkSimple "prop") + some (← mkAppM' i_prop #[e]) + | _ => none + +-- Collect the instances of `PropHasImp` for the subexpressions in the context +def collectPropHasImpInstancesFromMainCtx : Tactic.TacticM (HashSet Expr) := do + collectInstancesFromMainCtx lookupPropHasImp + +elab "display_prop_has_imp_instances" : tactic => do + trace[Arith] "Displaying the PropHasImp instances" + let hs ← collectPropHasImpInstancesFromMainCtx + hs.forM fun e => do + trace[Arith] "+ PropHasImp instance: {e}" + +example (x y : Int) (_ : x ≠ y) (_ : ¬ x = y) : True := by + display_prop_has_imp_instances + simp + +-- Lookup instances in a context and introduce them with additional declarations. +def introInstances (declToUnfold : Name) (lookup : Expr → MetaM (Option Expr)) : Tactic.TacticM (Array Expr) := do + let hs ← collectInstancesFromMainCtx lookup + hs.toArray.mapM fun e => do + let type ← inferType e + let name ← mkFreshUserName `h + -- Add a declaration + let nval ← Utils.addDeclTac name e type (asLet := false) + -- Simplify to unfold the declaration to unfold (i.e., the projector) + Utils.simpAt [declToUnfold] [] [] (Tactic.Location.targets #[mkIdent name] false) + -- Return the new value + pure nval + +def introHasIntPropInstances : Tactic.TacticM (Array Expr) := do + trace[Arith] "Introducing the HasIntProp instances" + introInstances ``HasIntProp.prop_ty lookupHasIntProp + +-- Lookup the instances of `HasIntProp for all the sub-expressions in the context, +-- and introduce the corresponding assumptions +elab "intro_has_int_prop_instances" : tactic => do + let _ ← introHasIntPropInstances + +-- Lookup the instances of `PropHasImp for all the sub-expressions in the context, +-- and introduce the corresponding assumptions +elab "intro_prop_has_imp_instances" : tactic => do + trace[Arith] "Introducing the PropHasImp instances" + let _ ← introInstances ``PropHasImp.concl lookupPropHasImp + +example (x y : Int) (h0 : x ≤ y) (h1 : x ≠ y) : x < y := by + intro_prop_has_imp_instances + rename_i h + split_disj h + . linarith + . linarith + +/- Boosting a bit the linarith tac. + + We do the following: + - for all the assumptions of the shape `(x : Int) ≠ y` or `¬ (x = y), we + introduce two goals with the assumptions `x < y` and `x > y` + TODO: we could create a PR for mathlib. + -/ +def intTacPreprocess (extraPreprocess : Tactic.TacticM Unit) : Tactic.TacticM Unit := do + Tactic.withMainContext do + -- Lookup the instances of PropHasImp (this is how we detect assumptions + -- of the proper shape), introduce assumptions in the context and split + -- on those + -- TODO: get rid of the assumptions that we split + let rec splitOnAsms (asms : List Expr) : Tactic.TacticM Unit := + match asms with + | [] => pure () + | asm :: asms => + let k := splitOnAsms asms + Utils.splitDisjTac asm k k + -- Introduce the scalar bounds + let _ ← introHasIntPropInstances + -- Extra preprocessing, before we split on the disjunctions + extraPreprocess + -- Split + let asms ← introInstances ``PropHasImp.concl lookupPropHasImp + splitOnAsms asms.toList + +elab "int_tac_preprocess" : tactic => + intTacPreprocess (do pure ()) + +def intTac (extraPreprocess : Tactic.TacticM Unit) : Tactic.TacticM Unit := do + Tactic.withMainContext do + Tactic.focus do + -- Preprocess - wondering if we should do this before or after splitting + -- the goal. I think before leads to a smaller proof term? + Tactic.allGoals (intTacPreprocess extraPreprocess) + -- Split the conjunctions in the goal + Tactic.allGoals (Utils.repeatTac Utils.splitConjTarget) + -- Call linarith + let linarith := + let cfg : Linarith.LinarithConfig := { + -- We do this with our custom preprocessing + splitNe := false + } + Tactic.liftMetaFinishingTactic <| Linarith.linarith false [] cfg + Tactic.allGoals linarith + +elab "int_tac" : tactic => + intTac (do pure ()) + +example (x : Int) (h0: 0 ≤ x) (h1: x ≠ 0) : 0 < x := by + int_tac_preprocess + linarith + linarith + +example (x : Int) (h0: 0 ≤ x) (h1: x ≠ 0) : 0 < x := by + int_tac + +-- Checking that things append correctly when there are several disjunctions +example (x y : Int) (h0: 0 ≤ x) (h1: x ≠ 0) (h2 : 0 ≤ y) (h3 : y ≠ 0) : 0 < x ∧ 0 < y := by + int_tac + +-- Checking that things append correctly when there are several disjunctions +example (x y : Int) (h0: 0 ≤ x) (h1: x ≠ 0) (h2 : 0 ≤ y) (h3 : y ≠ 0) : 0 < x ∧ 0 < y ∧ x + y ≥ 2 := by + int_tac + +end Arith diff --git a/backends/lean/Base/Arith/Scalar.lean b/backends/lean/Base/Arith/Scalar.lean new file mode 100644 index 00000000..f8903ecf --- /dev/null +++ b/backends/lean/Base/Arith/Scalar.lean @@ -0,0 +1,48 @@ +import Base.Arith.Int +import Base.Primitives.Scalar + +/- Automation for scalars - TODO: not sure it is worth having two files (Int.lean and Scalar.lean) -/ +namespace Arith + +open Lean Lean.Elab Lean.Meta +open Primitives + +def scalarTacExtraPreprocess : Tactic.TacticM Unit := do + Tactic.withMainContext do + -- Inroduce the bounds for the isize/usize types + let add (e : Expr) : Tactic.TacticM Unit := do + let ty ← inferType e + let _ ← Utils.addDeclTac (← mkFreshUserName `h) e ty (asLet := false) + add (← mkAppM ``Scalar.cMin_bound #[.const ``ScalarTy.Isize []]) + add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Usize []]) + add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Isize []]) + -- Reveal the concrete bounds + Utils.simpAt [``Scalar.min, ``Scalar.max, ``Scalar.cMin, ``Scalar.cMax, + ``I8.min, ``I16.min, ``I32.min, ``I64.min, ``I128.min, + ``I8.max, ``I16.max, ``I32.max, ``I64.max, ``I128.max, + ``U8.min, ``U16.min, ``U32.min, ``U64.min, ``U128.min, + ``U8.max, ``U16.max, ``U32.max, ``U64.max, ``U128.max + ] [] [] .wildcard + +elab "scalar_tac_preprocess" : tactic => + intTacPreprocess scalarTacExtraPreprocess + +-- A tactic to solve linear arithmetic goals in the presence of scalars +def scalarTac : Tactic.TacticM Unit := do + intTac scalarTacExtraPreprocess + +elab "scalar_tac" : tactic => + scalarTac + +instance (ty : ScalarTy) : HasIntProp (Scalar ty) where + -- prop_ty is inferred + prop := λ x => And.intro x.hmin x.hmax + +example (x y : U32) : x.val ≤ Scalar.max ScalarTy.U32 := by + intro_has_int_prop_instances + simp [*] + +example (x y : U32) : x.val ≤ Scalar.max ScalarTy.U32 := by + scalar_tac + +end Arith diff --git a/backends/lean/Base/IList.lean b/backends/lean/Base/IList.lean index 3db00cbb..31b66ffa 100644 --- a/backends/lean/Base/IList.lean +++ b/backends/lean/Base/IList.lean @@ -1,126 +1 @@ -/- Complementary list functions and lemmas which operate on integers rather - than natural numbers. -/ - -import Std.Data.Int.Lemmas -import Mathlib.Tactic.Linarith -import Base.Arith - -namespace List - -def len (ls : List α) : Int := - match ls with - | [] => 0 - | _ :: tl => 1 + len tl - --- Remark: if i < 0, then the result is none -def optIndex (i : Int) (ls : List α) : Option α := - match ls with - | [] => none - | hd :: tl => if i = 0 then some hd else optIndex (i - 1) tl - --- Remark: if i < 0, then the result is the defaul element -def index [Inhabited α] (i : Int) (ls : List α) : α := - match ls with - | [] => Inhabited.default - | x :: tl => - if i = 0 then x else index (i - 1) tl - --- Remark: the list is unchanged if the index is not in bounds (in particular --- if it is < 0) -def update (ls : List α) (i : Int) (y : α) : List α := - match ls with - | [] => [] - | x :: tl => if i = 0 then y :: tl else x :: update tl (i - 1) y - --- Remark: the whole list is dropped if the index is not in bounds (in particular --- if it is < 0) -def idrop (i : Int) (ls : List α) : List α := - match ls with - | [] => [] - | x :: tl => if i = 0 then x :: tl else idrop (i - 1) tl - -@[simp] theorem len_nil : len ([] : List α) = 0 := by simp [len] -@[simp] theorem len_cons : len ((x :: tl) : List α) = 1 + len tl := by simp [len] - -@[simp] theorem index_zero_cons [Inhabited α] : index 0 ((x :: tl) : List α) = x := by simp [index] -@[simp] theorem index_nzero_cons [Inhabited α] (hne : i ≠ 0) : index i ((x :: tl) : List α) = index (i - 1) tl := by simp [*, index] - -@[simp] theorem update_nil : update ([] : List α) i y = [] := by simp [update] -@[simp] theorem update_zero_cons : update ((x :: tl) : List α) 0 y = y :: tl := by simp [update] -@[simp] theorem update_nzero_cons (hne : i ≠ 0) : update ((x :: tl) : List α) i y = x :: update tl (i - 1) y := by simp [*, update] - -@[simp] theorem idrop_nil : idrop i ([] : List α) = [] := by simp [idrop] -@[simp] theorem idrop_zero : idrop 0 (ls : List α) = ls := by cases ls <;> simp [idrop] -@[simp] theorem idrop_nzero_cons (hne : i ≠ 0) : idrop i ((x :: tl) : List α) = idrop (i - 1) tl := by simp [*, idrop] - -theorem len_eq_length (ls : List α) : ls.len = ls.length := by - induction ls - . rfl - . simp [*, Int.ofNat_succ, Int.add_comm] - -theorem len_pos : 0 ≤ (ls : List α).len := by - induction ls <;> simp [*] - linarith - -instance (a : Type u) : Arith.HasIntProp (List a) where - prop_ty := λ ls => 0 ≤ ls.len - prop := λ ls => ls.len_pos - -@[simp] theorem len_append (l1 l2 : List α) : (l1 ++ l2).len = l1.len + l2.len := by - -- Remark: simp loops here because of the following rewritings: - -- @Nat.cast_add: ↑(List.length l1 + List.length l2) ==> ↑(List.length l1) + ↑(List.length l2) - -- Int.ofNat_add_ofNat: ↑(List.length l1) + ↑(List.length l2) ==> ↑(List.length l1 + List.length l2) - -- TODO: post an issue? - simp only [len_eq_length] - simp only [length_append] - simp only [Int.ofNat_add] - -theorem left_length_eq_append_eq (l1 l2 l1' l2' : List α) (heq : l1.length = l1'.length) : - l1 ++ l2 = l1' ++ l2' ↔ l1 = l1' ∧ l2 = l2' := by - revert l1' - induction l1 - . intro l1'; cases l1' <;> simp [*] - . intro l1'; cases l1' <;> simp_all; tauto - -theorem right_length_eq_append_eq (l1 l2 l1' l2' : List α) (heq : l2.length = l2'.length) : - l1 ++ l2 = l1' ++ l2' ↔ l1 = l1' ∧ l2 = l2' := by - have := left_length_eq_append_eq l1 l2 l1' l2' - constructor <;> intro heq2 <;> - have : l1.length + l2.length = l1'.length + l2'.length := by - have : (l1 ++ l2).length = (l1' ++ l2').length := by simp [*] - simp only [length_append] at this - apply this - . simp [heq] at this - tauto - . tauto - -theorem left_len_eq_append_eq (l1 l2 l1' l2' : List α) (heq : l1.len = l1'.len) : - l1 ++ l2 = l1' ++ l2' ↔ l1 = l1' ∧ l2 = l2' := by - simp [len_eq_length] at heq - apply left_length_eq_append_eq - assumption - -theorem right_len_eq_append_eq (l1 l2 l1' l2' : List α) (heq : l2.len = l2'.len) : - l1 ++ l2 = l1' ++ l2' ↔ l1 = l1' ∧ l2 = l2' := by - simp [len_eq_length] at heq - apply right_length_eq_append_eq - assumption - -open Arith in -theorem idrop_eq_nil_of_le (hineq : ls.len ≤ i) : idrop i ls = [] := by - revert i - induction ls <;> simp [*] - rename_i hd tl hi - intro i hineq - if heq: i = 0 then - simp [*] at * - have := tl.len_pos - linarith - else - simp at hineq - have : 0 < i := by int_tac - simp [*] - apply hi - linarith - -end List +import Base.IList.IList diff --git a/backends/lean/Base/IList/IList.lean b/backends/lean/Base/IList/IList.lean new file mode 100644 index 00000000..2a335cac --- /dev/null +++ b/backends/lean/Base/IList/IList.lean @@ -0,0 +1,142 @@ +/- Complementary list functions and lemmas which operate on integers rather + than natural numbers. -/ + +import Std.Data.Int.Lemmas +import Base.Arith + +namespace List + +def len (ls : List α) : Int := + match ls with + | [] => 0 + | _ :: tl => 1 + len tl + +-- Remark: if i < 0, then the result is none +def indexOpt (ls : List α) (i : Int) : Option α := + match ls with + | [] => none + | hd :: tl => if i = 0 then some hd else indexOpt tl (i - 1) + +-- Remark: if i < 0, then the result is the defaul element +def index [Inhabited α] (ls : List α) (i : Int) : α := + match ls with + | [] => Inhabited.default + | x :: tl => + if i = 0 then x else index tl (i - 1) + +-- Remark: the list is unchanged if the index is not in bounds (in particular +-- if it is < 0) +def update (ls : List α) (i : Int) (y : α) : List α := + match ls with + | [] => [] + | x :: tl => if i = 0 then y :: tl else x :: update tl (i - 1) y + +-- Remark: the whole list is dropped if the index is not in bounds (in particular +-- if it is < 0) +def idrop (i : Int) (ls : List α) : List α := + match ls with + | [] => [] + | x :: tl => if i = 0 then x :: tl else idrop (i - 1) tl + +section Lemmas + +variable {α : Type u} + +@[simp] theorem len_nil : len ([] : List α) = 0 := by simp [len] +@[simp] theorem len_cons : len ((x :: tl) : List α) = 1 + len tl := by simp [len] + +@[simp] theorem index_zero_cons [Inhabited α] : index ((x :: tl) : List α) 0 = x := by simp [index] +@[simp] theorem index_nzero_cons [Inhabited α] (hne : i ≠ 0) : index ((x :: tl) : List α) i = index tl (i - 1) := by simp [*, index] + +@[simp] theorem update_nil : update ([] : List α) i y = [] := by simp [update] +@[simp] theorem update_zero_cons : update ((x :: tl) : List α) 0 y = y :: tl := by simp [update] +@[simp] theorem update_nzero_cons (hne : i ≠ 0) : update ((x :: tl) : List α) i y = x :: update tl (i - 1) y := by simp [*, update] + +@[simp] theorem idrop_nil : idrop i ([] : List α) = [] := by simp [idrop] +@[simp] theorem idrop_zero : idrop 0 (ls : List α) = ls := by cases ls <;> simp [idrop] +@[simp] theorem idrop_nzero_cons (hne : i ≠ 0) : idrop i ((x :: tl) : List α) = idrop (i - 1) tl := by simp [*, idrop] + +theorem len_eq_length (ls : List α) : ls.len = ls.length := by + induction ls + . rfl + . simp [*, Int.ofNat_succ, Int.add_comm] + +@[simp] theorem len_append (l1 l2 : List α) : (l1 ++ l2).len = l1.len + l2.len := by + -- Remark: simp loops here because of the following rewritings: + -- @Nat.cast_add: ↑(List.length l1 + List.length l2) ==> ↑(List.length l1) + ↑(List.length l2) + -- Int.ofNat_add_ofNat: ↑(List.length l1) + ↑(List.length l2) ==> ↑(List.length l1 + List.length l2) + -- TODO: post an issue? + simp only [len_eq_length] + simp only [length_append] + simp only [Int.ofNat_add] + +@[simp] +theorem length_update (ls : List α) (i : Int) (x : α) : (ls.update i x).length = ls.length := by + revert i + induction ls <;> simp_all [length, update] + intro; split <;> simp [*] + +@[simp] +theorem len_update (ls : List α) (i : Int) (x : α) : (ls.update i x).len = ls.len := by + simp [len_eq_length] + + +theorem len_pos : 0 ≤ (ls : List α).len := by + induction ls <;> simp [*] + linarith + +instance (a : Type u) : Arith.HasIntProp (List a) where + prop_ty := λ ls => 0 ≤ ls.len + prop := λ ls => ls.len_pos + +theorem left_length_eq_append_eq (l1 l2 l1' l2' : List α) (heq : l1.length = l1'.length) : + l1 ++ l2 = l1' ++ l2' ↔ l1 = l1' ∧ l2 = l2' := by + revert l1' + induction l1 + . intro l1'; cases l1' <;> simp [*] + . intro l1'; cases l1' <;> simp_all; tauto + +theorem right_length_eq_append_eq (l1 l2 l1' l2' : List α) (heq : l2.length = l2'.length) : + l1 ++ l2 = l1' ++ l2' ↔ l1 = l1' ∧ l2 = l2' := by + have := left_length_eq_append_eq l1 l2 l1' l2' + constructor <;> intro heq2 <;> + have : l1.length + l2.length = l1'.length + l2'.length := by + have : (l1 ++ l2).length = (l1' ++ l2').length := by simp [*] + simp only [length_append] at this + apply this + . simp [heq] at this + tauto + . tauto + +theorem left_len_eq_append_eq (l1 l2 l1' l2' : List α) (heq : l1.len = l1'.len) : + l1 ++ l2 = l1' ++ l2' ↔ l1 = l1' ∧ l2 = l2' := by + simp [len_eq_length] at heq + apply left_length_eq_append_eq + assumption + +theorem right_len_eq_append_eq (l1 l2 l1' l2' : List α) (heq : l2.len = l2'.len) : + l1 ++ l2 = l1' ++ l2' ↔ l1 = l1' ∧ l2 = l2' := by + simp [len_eq_length] at heq + apply right_length_eq_append_eq + assumption + +open Arith in +theorem idrop_eq_nil_of_le (hineq : ls.len ≤ i) : idrop i ls = [] := by + revert i + induction ls <;> simp [*] + rename_i hd tl hi + intro i hineq + if heq: i = 0 then + simp [*] at * + have := tl.len_pos + linarith + else + simp at hineq + have : 0 < i := by int_tac + simp [*] + apply hi + linarith + +end Lemmas + +end List diff --git a/backends/lean/Base/Primitives.lean b/backends/lean/Base/Primitives.lean index 1a0c665d..91823cb6 100644 --- a/backends/lean/Base/Primitives.lean +++ b/backends/lean/Base/Primitives.lean @@ -1,715 +1,3 @@ -import Lean -import Lean.Meta.Tactic.Simp -import Init.Data.List.Basic -import Mathlib.Tactic.RunCmd -import Mathlib.Tactic.Linarith - -namespace Primitives - --------------------- --- ASSERT COMMAND --Std. --------------------- - -open Lean Elab Command Term Meta - -syntax (name := assert) "#assert" term: command - -@[command_elab assert] -unsafe -def assertImpl : CommandElab := fun (_stx: Syntax) => do - runTermElabM (fun _ => do - let r ← evalTerm Bool (mkConst ``Bool) _stx[1] - if not r then - logInfo ("Assertion failed for:\n" ++ _stx[1]) - throwError ("Expression reduced to false:\n" ++ _stx[1]) - pure ()) - -#eval 2 == 2 -#assert (2 == 2) - -------------- --- PRELUDE -- -------------- - --- Results & monadic combinators - -inductive Error where - | assertionFailure: Error - | integerOverflow: Error - | divisionByZero: Error - | arrayOutOfBounds: Error - | maximumSizeExceeded: Error - | panic: Error -deriving Repr, BEq - -open Error - -inductive Result (α : Type u) where - | ret (v: α): Result α - | fail (e: Error): Result α - | div -deriving Repr, BEq - -open Result - -instance Result_Inhabited (α : Type u) : Inhabited (Result α) := - Inhabited.mk (fail panic) - -instance Result_Nonempty (α : Type u) : Nonempty (Result α) := - Nonempty.intro div - -/- HELPERS -/ - -def ret? {α: Type u} (r: Result α): Bool := - match r with - | ret _ => true - | fail _ | div => false - -def div? {α: Type u} (r: Result α): Bool := - match r with - | div => true - | ret _ | fail _ => false - -def massert (b:Bool) : Result Unit := - if b then ret () else fail assertionFailure - -def eval_global {α: Type u} (x: Result α) (_: ret? x): α := - match x with - | fail _ | div => by contradiction - | ret x => x - -/- DO-DSL SUPPORT -/ - -def bind {α : Type u} {β : Type v} (x: Result α) (f: α -> Result β) : Result β := - match x with - | ret v => f v - | fail v => fail v - | div => div - --- Allows using Result in do-blocks -instance : Bind Result where - bind := bind - --- Allows using return x in do-blocks -instance : Pure Result where - pure := fun x => ret x - -@[simp] theorem bind_ret (x : α) (f : α → Result β) : bind (.ret x) f = f x := by simp [bind] -@[simp] theorem bind_fail (x : Error) (f : α → Result β) : bind (.fail x) f = .fail x := by simp [bind] -@[simp] theorem bind_div (f : α → Result β) : bind .div f = .div := by simp [bind] - -/- CUSTOM-DSL SUPPORT -/ - --- Let-binding the Result of a monadic operation is oftentimes not sufficient, --- because we may need a hypothesis for equational reasoning in the scope. We --- rely on subtype, and a custom let-binding operator, in effect recreating our --- own variant of the do-dsl - -def Result.attach {α: Type} (o : Result α): Result { x : α // o = ret x } := - match o with - | ret x => ret ⟨x, rfl⟩ - | fail e => fail e - | div => div - -@[simp] theorem bind_tc_ret (x : α) (f : α → Result β) : - (do let y ← .ret x; f y) = f x := by simp [Bind.bind, bind] - -@[simp] theorem bind_tc_fail (x : Error) (f : α → Result β) : - (do let y ← fail x; f y) = fail x := by simp [Bind.bind, bind] - -@[simp] theorem bind_tc_div (f : α → Result β) : - (do let y ← div; f y) = div := by simp [Bind.bind, bind] - ----------------------- --- MACHINE INTEGERS -- ----------------------- - --- We redefine our machine integers types. - --- For Isize/Usize, we reuse `getNumBits` from `USize`. You cannot reduce `getNumBits` --- using the simplifier, meaning that proofs do not depend on the compile-time value of --- USize.size. (Lean assumes 32 or 64-bit platforms, and Rust doesn't really support, at --- least officially, 16-bit microcontrollers, so this seems like a fine design decision --- for now.) - --- Note from Chris Bailey: "If there's more than one salient property of your --- definition then the subtyping strategy might get messy, and the property part --- of a subtype is less discoverable by the simplifier or tactics like --- library_search." So, we will not add refinements on the return values of the --- operations defined on Primitives, but will rather rely on custom lemmas to --- invert on possible return values of the primitive operations. - --- Machine integer constants, done via `ofNatCore`, which requires a proof that --- the `Nat` fits within the desired integer type. We provide a custom tactic. - -open System.Platform.getNumBits - --- TODO: is there a way of only importing System.Platform.getNumBits? --- -@[simp] def size_num_bits : Nat := (System.Platform.getNumBits ()).val - --- Remark: Lean seems to use < for the comparisons with the upper bounds by convention. - --- The "structured" bounds -def Isize.smin : Int := - (HPow.hPow 2 (size_num_bits - 1)) -def Isize.smax : Int := (HPow.hPow 2 (size_num_bits - 1)) - 1 -def I8.smin : Int := - (HPow.hPow 2 7) -def I8.smax : Int := HPow.hPow 2 7 - 1 -def I16.smin : Int := - (HPow.hPow 2 15) -def I16.smax : Int := HPow.hPow 2 15 - 1 -def I32.smin : Int := -(HPow.hPow 2 31) -def I32.smax : Int := HPow.hPow 2 31 - 1 -def I64.smin : Int := -(HPow.hPow 2 63) -def I64.smax : Int := HPow.hPow 2 63 - 1 -def I128.smin : Int := -(HPow.hPow 2 127) -def I128.smax : Int := HPow.hPow 2 127 - 1 -def Usize.smin : Int := 0 -def Usize.smax : Int := HPow.hPow 2 size_num_bits - 1 -def U8.smin : Int := 0 -def U8.smax : Int := HPow.hPow 2 8 - 1 -def U16.smin : Int := 0 -def U16.smax : Int := HPow.hPow 2 16 - 1 -def U32.smin : Int := 0 -def U32.smax : Int := HPow.hPow 2 32 - 1 -def U64.smin : Int := 0 -def U64.smax : Int := HPow.hPow 2 64 - 1 -def U128.smin : Int := 0 -def U128.smax : Int := HPow.hPow 2 128 - 1 - --- The "normalized" bounds, that we use in practice -def I8.min := -128 -def I8.max := 127 -def I16.min := -32768 -def I16.max := 32767 -def I32.min := -2147483648 -def I32.max := 2147483647 -def I64.min := -9223372036854775808 -def I64.max := 9223372036854775807 -def I128.min := -170141183460469231731687303715884105728 -def I128.max := 170141183460469231731687303715884105727 -@[simp] def U8.min := 0 -def U8.max := 255 -@[simp] def U16.min := 0 -def U16.max := 65535 -@[simp] def U32.min := 0 -def U32.max := 4294967295 -@[simp] def U64.min := 0 -def U64.max := 18446744073709551615 -@[simp] def U128.min := 0 -def U128.max := 340282366920938463463374607431768211455 -@[simp] def Usize.min := 0 - -def Isize.refined_min : { n:Int // n = I32.min ∨ n = I64.min } := - ⟨ Isize.smin, by - simp [Isize.smin] - cases System.Platform.numBits_eq <;> - unfold System.Platform.numBits at * <;> simp [*] ⟩ - -def Isize.refined_max : { n:Int // n = I32.max ∨ n = I64.max } := - ⟨ Isize.smax, by - simp [Isize.smax] - cases System.Platform.numBits_eq <;> - unfold System.Platform.numBits at * <;> simp [*] ⟩ - -def Usize.refined_max : { n:Int // n = U32.max ∨ n = U64.max } := - ⟨ Usize.smax, by - simp [Usize.smax] - cases System.Platform.numBits_eq <;> - unfold System.Platform.numBits at * <;> simp [*] ⟩ - -def Isize.min := Isize.refined_min.val -def Isize.max := Isize.refined_max.val -def Usize.max := Usize.refined_max.val - -inductive ScalarTy := -| Isize -| I8 -| I16 -| I32 -| I64 -| I128 -| Usize -| U8 -| U16 -| U32 -| U64 -| U128 - -def Scalar.smin (ty : ScalarTy) : Int := - match ty with - | .Isize => Isize.smin - | .I8 => I8.smin - | .I16 => I16.smin - | .I32 => I32.smin - | .I64 => I64.smin - | .I128 => I128.smin - | .Usize => Usize.smin - | .U8 => U8.smin - | .U16 => U16.smin - | .U32 => U32.smin - | .U64 => U64.smin - | .U128 => U128.smin - -def Scalar.smax (ty : ScalarTy) : Int := - match ty with - | .Isize => Isize.smax - | .I8 => I8.smax - | .I16 => I16.smax - | .I32 => I32.smax - | .I64 => I64.smax - | .I128 => I128.smax - | .Usize => Usize.smax - | .U8 => U8.smax - | .U16 => U16.smax - | .U32 => U32.smax - | .U64 => U64.smax - | .U128 => U128.smax - -def Scalar.min (ty : ScalarTy) : Int := - match ty with - | .Isize => Isize.min - | .I8 => I8.min - | .I16 => I16.min - | .I32 => I32.min - | .I64 => I64.min - | .I128 => I128.min - | .Usize => Usize.min - | .U8 => U8.min - | .U16 => U16.min - | .U32 => U32.min - | .U64 => U64.min - | .U128 => U128.min - -def Scalar.max (ty : ScalarTy) : Int := - match ty with - | .Isize => Isize.max - | .I8 => I8.max - | .I16 => I16.max - | .I32 => I32.max - | .I64 => I64.max - | .I128 => I128.max - | .Usize => Usize.max - | .U8 => U8.max - | .U16 => U16.max - | .U32 => U32.max - | .U64 => U64.max - | .U128 => U128.max - -def Scalar.smin_eq (ty : ScalarTy) : Scalar.min ty = Scalar.smin ty := by - cases ty <;> rfl - -def Scalar.smax_eq (ty : ScalarTy) : Scalar.max ty = Scalar.smax ty := by - cases ty <;> rfl - --- "Conservative" bounds --- We use those because we can't compare to the isize bounds (which can't --- reduce at compile-time). Whenever we perform an arithmetic operation like --- addition we need to check that the result is in bounds: we first compare --- to the conservative bounds, which reduce, then compare to the real bounds. --- This is useful for the various #asserts that we want to reduce at --- type-checking time. -def Scalar.cMin (ty : ScalarTy) : Int := - match ty with - | .Isize => Scalar.min .I32 - | _ => Scalar.min ty - -def Scalar.cMax (ty : ScalarTy) : Int := - match ty with - | .Isize => Scalar.max .I32 - | .Usize => Scalar.max .U32 - | _ => Scalar.max ty - -theorem Scalar.cMin_bound ty : Scalar.min ty ≤ Scalar.cMin ty := by - cases ty <;> simp [Scalar.min, Scalar.max, Scalar.cMin, Scalar.cMax] at * - have h := Isize.refined_min.property - cases h <;> simp [*, Isize.min] - -theorem Scalar.cMax_bound ty : Scalar.cMax ty ≤ Scalar.max ty := by - cases ty <;> simp [Scalar.min, Scalar.max, Scalar.cMin, Scalar.cMax] at * - . have h := Isize.refined_max.property - cases h <;> simp [*, Isize.max] - . have h := Usize.refined_max.property - cases h <;> simp [*, Usize.max] - -theorem Scalar.cMin_suffices ty (h : Scalar.cMin ty ≤ x) : Scalar.min ty ≤ x := by - have := Scalar.cMin_bound ty - linarith - -theorem Scalar.cMax_suffices ty (h : x ≤ Scalar.cMax ty) : x ≤ Scalar.max ty := by - have := Scalar.cMax_bound ty - linarith - -structure Scalar (ty : ScalarTy) where - val : Int - hmin : Scalar.min ty ≤ val - hmax : val ≤ Scalar.max ty -deriving Repr - -theorem Scalar.bound_suffices (ty : ScalarTy) (x : Int) : - Scalar.cMin ty ≤ x ∧ x ≤ Scalar.cMax ty -> - Scalar.min ty ≤ x ∧ x ≤ Scalar.max ty - := - λ h => by - apply And.intro <;> have hmin := Scalar.cMin_bound ty <;> have hmax := Scalar.cMax_bound ty <;> linarith - -def Scalar.ofIntCore {ty : ScalarTy} (x : Int) - (hmin : Scalar.min ty ≤ x) (hmax : x ≤ Scalar.max ty) : Scalar ty := - { val := x, hmin := hmin, hmax := hmax } - --- Tactic to prove that integers are in bounds --- TODO: use this: https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/instance.20with.20tactic.20autoparam -syntax "intlit" : tactic -macro_rules - | `(tactic| intlit) => `(tactic| apply Scalar.bound_suffices; decide) - -def Scalar.ofInt {ty : ScalarTy} (x : Int) - (h : Scalar.min ty ≤ x ∧ x ≤ Scalar.max ty := by intlit) : Scalar ty := - -- Remark: we initially wrote: - -- let ⟨ hmin, hmax ⟩ := h - -- Scalar.ofIntCore x hmin hmax - -- We updated to the line below because a similar pattern in `Scalar.tryMk` - -- made reduction block. Both versions seem to work for `Scalar.ofInt`, though. - -- TODO: investigate - Scalar.ofIntCore x h.left h.right - -@[simp] def Scalar.check_bounds (ty : ScalarTy) (x : Int) : Bool := - (Scalar.cMin ty ≤ x || Scalar.min ty ≤ x) ∧ (x ≤ Scalar.cMax ty || x ≤ Scalar.max ty) - -theorem Scalar.check_bounds_prop {ty : ScalarTy} {x : Int} (h: Scalar.check_bounds ty x) : - Scalar.min ty ≤ x ∧ x ≤ Scalar.max ty := by - simp at * - have ⟨ hmin, hmax ⟩ := h - have hbmin := Scalar.cMin_bound ty - have hbmax := Scalar.cMax_bound ty - cases hmin <;> cases hmax <;> apply And.intro <;> linarith - --- Further thoughts: look at what has been done here: --- https://github.com/leanprover-community/mathlib4/blob/master/Mathlib/Data/Fin/Basic.lean --- and --- https://github.com/leanprover-community/mathlib4/blob/master/Mathlib/Data/UInt.lean --- which both contain a fair amount of reasoning already! -def Scalar.tryMk (ty : ScalarTy) (x : Int) : Result (Scalar ty) := - if h:Scalar.check_bounds ty x then - -- If we do: - -- ``` - -- let ⟨ hmin, hmax ⟩ := (Scalar.check_bounds_prop h) - -- Scalar.ofIntCore x hmin hmax - -- ``` - -- then normalization blocks (for instance, some proofs which use reflexivity fail). - -- However, the version below doesn't block reduction (TODO: investigate): - return Scalar.ofInt x (Scalar.check_bounds_prop h) - else fail integerOverflow - -def Scalar.neg {ty : ScalarTy} (x : Scalar ty) : Result (Scalar ty) := Scalar.tryMk ty (- x.val) - -def Scalar.div {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar ty) := - if y.val != 0 then Scalar.tryMk ty (x.val / y.val) else fail divisionByZero - --- Our custom remainder operation, which satisfies the semantics of Rust --- TODO: is there a better way? -def scalar_rem (x y : Int) : Int := - if 0 ≤ x then |x| % |y| - else - (|x| % |y|) - --- Our custom division operation, which satisfies the semantics of Rust --- TODO: is there a better way? -def scalar_div (x y : Int) : Int := - if 0 ≤ x && 0 ≤ y then |x| / |y| - else if 0 ≤ x && y < 0 then - (|x| / |y|) - else if x < 0 && 0 ≤ y then - (|x| / |y|) - else |x| / |y| - --- Checking that the remainder operation is correct -#assert scalar_rem 1 2 = 1 -#assert scalar_rem (-1) 2 = -1 -#assert scalar_rem 1 (-2) = 1 -#assert scalar_rem (-1) (-2) = -1 -#assert scalar_rem 7 3 = (1:Int) -#assert scalar_rem (-7) 3 = -1 -#assert scalar_rem 7 (-3) = 1 -#assert scalar_rem (-7) (-3) = -1 - --- Checking that the division operation is correct -#assert scalar_div 3 2 = 1 -#assert scalar_div (-3) 2 = -1 -#assert scalar_div 3 (-2) = -1 -#assert scalar_div (-3) (-2) = 1 -#assert scalar_div 7 3 = 2 -#assert scalar_div (-7) 3 = -2 -#assert scalar_div 7 (-3) = -2 -#assert scalar_div (-7) (-3) = 2 - -def Scalar.rem {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar ty) := - if y.val != 0 then Scalar.tryMk ty (x.val % y.val) else fail divisionByZero - -def Scalar.add {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar ty) := - Scalar.tryMk ty (x.val + y.val) - -def Scalar.sub {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar ty) := - Scalar.tryMk ty (x.val - y.val) - -def Scalar.mul {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar ty) := - Scalar.tryMk ty (x.val * y.val) - --- TODO: instances of +, -, * etc. for scalars - --- Cast an integer from a [src_ty] to a [tgt_ty] --- TODO: check the semantics of casts in Rust -def Scalar.cast {src_ty : ScalarTy} (tgt_ty : ScalarTy) (x : Scalar src_ty) : Result (Scalar tgt_ty) := - Scalar.tryMk tgt_ty x.val - --- The scalar types --- We declare the definitions as reducible so that Lean can unfold them (useful --- for type class resolution for instance). -@[reducible] def Isize := Scalar .Isize -@[reducible] def I8 := Scalar .I8 -@[reducible] def I16 := Scalar .I16 -@[reducible] def I32 := Scalar .I32 -@[reducible] def I64 := Scalar .I64 -@[reducible] def I128 := Scalar .I128 -@[reducible] def Usize := Scalar .Usize -@[reducible] def U8 := Scalar .U8 -@[reducible] def U16 := Scalar .U16 -@[reducible] def U32 := Scalar .U32 -@[reducible] def U64 := Scalar .U64 -@[reducible] def U128 := Scalar .U128 - --- TODO: below: not sure this is the best way. --- Should we rather overload operations like +, -, etc.? --- Also, it is possible to automate the generation of those definitions --- with macros (but would it be a good idea? It would be less easy to --- read the file, which is not supposed to change a lot) - --- Negation - -/-- -Remark: there is no heterogeneous negation in the Lean prelude: we thus introduce -one here. - -The notation typeclass for heterogeneous addition. -This enables the notation `- a : β` where `a : α`. --/ -class HNeg (α : Type u) (β : outParam (Type v)) where - /-- `- a` computes the negation of `a`. - The meaning of this notation is type-dependent. -/ - hNeg : α → β - -prefix:75 "-" => HNeg.hNeg - -instance : HNeg Isize (Result Isize) where hNeg x := Scalar.neg x -instance : HNeg I8 (Result I8) where hNeg x := Scalar.neg x -instance : HNeg I16 (Result I16) where hNeg x := Scalar.neg x -instance : HNeg I32 (Result I32) where hNeg x := Scalar.neg x -instance : HNeg I64 (Result I64) where hNeg x := Scalar.neg x -instance : HNeg I128 (Result I128) where hNeg x := Scalar.neg x - --- Addition -instance {ty} : HAdd (Scalar ty) (Scalar ty) (Result (Scalar ty)) where - hAdd x y := Scalar.add x y - --- Substraction -instance {ty} : HSub (Scalar ty) (Scalar ty) (Result (Scalar ty)) where - hSub x y := Scalar.sub x y - --- Multiplication -instance {ty} : HMul (Scalar ty) (Scalar ty) (Result (Scalar ty)) where - hMul x y := Scalar.mul x y - --- Division -instance {ty} : HDiv (Scalar ty) (Scalar ty) (Result (Scalar ty)) where - hDiv x y := Scalar.div x y - --- Remainder -instance {ty} : HMod (Scalar ty) (Scalar ty) (Result (Scalar ty)) where - hMod x y := Scalar.rem x y - --- ofIntCore --- TODO: typeclass? -def Isize.ofIntCore := @Scalar.ofIntCore .Isize -def I8.ofIntCore := @Scalar.ofIntCore .I8 -def I16.ofIntCore := @Scalar.ofIntCore .I16 -def I32.ofIntCore := @Scalar.ofIntCore .I32 -def I64.ofIntCore := @Scalar.ofIntCore .I64 -def I128.ofIntCore := @Scalar.ofIntCore .I128 -def Usize.ofIntCore := @Scalar.ofIntCore .Usize -def U8.ofIntCore := @Scalar.ofIntCore .U8 -def U16.ofIntCore := @Scalar.ofIntCore .U16 -def U32.ofIntCore := @Scalar.ofIntCore .U32 -def U64.ofIntCore := @Scalar.ofIntCore .U64 -def U128.ofIntCore := @Scalar.ofIntCore .U128 - --- ofInt --- TODO: typeclass? -def Isize.ofInt := @Scalar.ofInt .Isize -def I8.ofInt := @Scalar.ofInt .I8 -def I16.ofInt := @Scalar.ofInt .I16 -def I32.ofInt := @Scalar.ofInt .I32 -def I64.ofInt := @Scalar.ofInt .I64 -def I128.ofInt := @Scalar.ofInt .I128 -def Usize.ofInt := @Scalar.ofInt .Usize -def U8.ofInt := @Scalar.ofInt .U8 -def U16.ofInt := @Scalar.ofInt .U16 -def U32.ofInt := @Scalar.ofInt .U32 -def U64.ofInt := @Scalar.ofInt .U64 -def U128.ofInt := @Scalar.ofInt .U128 - --- Comparisons -instance {ty} : LT (Scalar ty) where - lt a b := LT.lt a.val b.val - -instance {ty} : LE (Scalar ty) where le a b := LE.le a.val b.val - -instance Scalar.decLt {ty} (a b : Scalar ty) : Decidable (LT.lt a b) := Int.decLt .. -instance Scalar.decLe {ty} (a b : Scalar ty) : Decidable (LE.le a b) := Int.decLe .. - -theorem Scalar.eq_of_val_eq {ty} : ∀ {i j : Scalar ty}, Eq i.val j.val → Eq i j - | ⟨_, _, _⟩, ⟨_, _, _⟩, rfl => rfl - -theorem Scalar.val_eq_of_eq {ty} {i j : Scalar ty} (h : Eq i j) : Eq i.val j.val := - h ▸ rfl - -theorem Scalar.ne_of_val_ne {ty} {i j : Scalar ty} (h : Not (Eq i.val j.val)) : Not (Eq i j) := - fun h' => absurd (val_eq_of_eq h') h - -instance (ty : ScalarTy) : DecidableEq (Scalar ty) := - fun i j => - match decEq i.val j.val with - | isTrue h => isTrue (Scalar.eq_of_val_eq h) - | isFalse h => isFalse (Scalar.ne_of_val_ne h) - -def Scalar.toInt {ty} (n : Scalar ty) : Int := n.val - --- -- We now define a type class that subsumes the various machine integer types, so --- -- as to write a concise definition for scalar_cast, rather than exhaustively --- -- enumerating all of the possible pairs. We remark that Rust has sane semantics --- -- and fails if a cast operation would involve a truncation or modulo. - --- class MachineInteger (t: Type) where --- size: Nat --- val: t -> Fin size --- ofNatCore: (n:Nat) -> LT.lt n size -> t - --- set_option hygiene false in --- run_cmd --- for typeName in [`UInt8, `UInt16, `UInt32, `UInt64, `USize].map Lean.mkIdent do --- Lean.Elab.Command.elabCommand (← `( --- namespace $typeName --- instance: MachineInteger $typeName where --- size := size --- val := val --- ofNatCore := ofNatCore --- end $typeName --- )) - --- -- Aeneas only instantiates the destination type (`src` is implicit). We rely on --- -- Lean to infer `src`. - --- def scalar_cast { src: Type } (dst: Type) [ MachineInteger src ] [ MachineInteger dst ] (x: src): Result dst := --- if h: MachineInteger.val x < MachineInteger.size dst then --- .ret (MachineInteger.ofNatCore (MachineInteger.val x).val h) --- else --- .fail integerOverflow - -------------- --- VECTORS -- -------------- - -def Vec (α : Type u) := { l : List α // List.length l ≤ Usize.max } - --- TODO: do we really need it? It should be with Subtype by default -instance Vec.cast (a : Type): Coe (Vec a) (List a) where coe := λ v => v.val - -def Vec.new (α : Type u): Vec α := ⟨ [], by apply Scalar.cMax_suffices .Usize; simp ⟩ - -def Vec.len (α : Type u) (v : Vec α) : Usize := - let ⟨ v, l ⟩ := v - Usize.ofIntCore (List.length v) (by simp [Scalar.min, Usize.min]) l - --- This shouldn't be used -def Vec.push_fwd (α : Type u) (_ : Vec α) (_ : α) : Unit := () - --- This is actually the backward function -def Vec.push (α : Type u) (v : Vec α) (x : α) : Result (Vec α) - := - let nlen := List.length v.val + 1 - if h : nlen ≤ U32.max || nlen ≤ Usize.max then - have h : nlen ≤ Usize.max := by - simp [Usize.max] at * - have hm := Usize.refined_max.property - cases h <;> cases hm <;> simp [U32.max, U64.max] at * <;> try linarith - return ⟨ List.concat v.val x, by simp at *; assumption ⟩ - else - fail maximumSizeExceeded - --- This shouldn't be used -def Vec.insert_fwd (α : Type u) (v: Vec α) (i: Usize) (_: α): Result Unit := - if i.val < List.length v.val then - .ret () - else - .fail arrayOutOfBounds - --- This is actually the backward function -def Vec.insert (α : Type u) (v: Vec α) (i: Usize) (x: α): Result (Vec α) := - if i.val < List.length v.val then - -- TODO: maybe we should redefine a list library which uses integers - -- (instead of natural numbers) - let i := i.val.toNat - .ret ⟨ List.set v.val i x, by - have h: List.length v.val ≤ Usize.max := v.property - simp [*] at * - ⟩ - else - .fail arrayOutOfBounds - -def Vec.index_to_fin {α : Type u} {v: Vec α} {i: Usize} (h : i.val < List.length v.val) : - Fin (List.length v.val) := - let j := i.val.toNat - let h: j < List.length v.val := by - have heq := @Int.toNat_lt (List.length v.val) i.val i.hmin - apply heq.mpr - assumption - ⟨j, h⟩ - -def Vec.index (α : Type u) (v: Vec α) (i: Usize): Result α := - if h: i.val < List.length v.val then - let i := Vec.index_to_fin h - .ret (List.get v.val i) - else - .fail arrayOutOfBounds - --- This shouldn't be used -def Vec.index_back (α : Type u) (v: Vec α) (i: Usize) (_: α): Result Unit := - if i.val < List.length v.val then - .ret () - else - .fail arrayOutOfBounds - -def Vec.index_mut (α : Type u) (v: Vec α) (i: Usize): Result α := - if h: i.val < List.length v.val then - let i := Vec.index_to_fin h - .ret (List.get v.val i) - else - .fail arrayOutOfBounds - -def Vec.index_mut_back (α : Type u) (v: Vec α) (i: Usize) (x: α): Result (Vec α) := - if h: i.val < List.length v.val then - let i := Vec.index_to_fin h - .ret ⟨ List.set v.val i x, by - have h: List.length v.val ≤ Usize.max := v.property - simp [*] at * - ⟩ - else - .fail arrayOutOfBounds - ----------- --- MISC -- ----------- - -@[simp] def mem.replace (a : Type) (x : a) (_ : a) : a := x -@[simp] def mem.replace_back (a : Type) (_ : a) (y : a) : a := y - -/-- Aeneas-translated function -- useful to reduce non-recursive definitions. - Use with `simp [ aeneas ]` -/ -register_simp_attr aeneas - -end Primitives +import Base.Primitives.Base +import Base.Primitives.Scalar +import Base.Primitives.Vec diff --git a/backends/lean/Base/Primitives/Base.lean b/backends/lean/Base/Primitives/Base.lean new file mode 100644 index 00000000..db462c38 --- /dev/null +++ b/backends/lean/Base/Primitives/Base.lean @@ -0,0 +1,130 @@ +import Lean + +namespace Primitives + +-------------------- +-- ASSERT COMMAND --Std. +-------------------- + +open Lean Elab Command Term Meta + +syntax (name := assert) "#assert" term: command + +@[command_elab assert] +unsafe +def assertImpl : CommandElab := fun (_stx: Syntax) => do + runTermElabM (fun _ => do + let r ← evalTerm Bool (mkConst ``Bool) _stx[1] + if not r then + logInfo ("Assertion failed for:\n" ++ _stx[1]) + throwError ("Expression reduced to false:\n" ++ _stx[1]) + pure ()) + +#eval 2 == 2 +#assert (2 == 2) + +------------- +-- PRELUDE -- +------------- + +-- Results & monadic combinators + +inductive Error where + | assertionFailure: Error + | integerOverflow: Error + | divisionByZero: Error + | arrayOutOfBounds: Error + | maximumSizeExceeded: Error + | panic: Error +deriving Repr, BEq + +open Error + +inductive Result (α : Type u) where + | ret (v: α): Result α + | fail (e: Error): Result α + | div +deriving Repr, BEq + +open Result + +instance Result_Inhabited (α : Type u) : Inhabited (Result α) := + Inhabited.mk (fail panic) + +instance Result_Nonempty (α : Type u) : Nonempty (Result α) := + Nonempty.intro div + +/- HELPERS -/ + +def ret? {α: Type u} (r: Result α): Bool := + match r with + | ret _ => true + | fail _ | div => false + +def div? {α: Type u} (r: Result α): Bool := + match r with + | div => true + | ret _ | fail _ => false + +def massert (b:Bool) : Result Unit := + if b then ret () else fail assertionFailure + +def eval_global {α: Type u} (x: Result α) (_: ret? x): α := + match x with + | fail _ | div => by contradiction + | ret x => x + +/- DO-DSL SUPPORT -/ + +def bind {α : Type u} {β : Type v} (x: Result α) (f: α -> Result β) : Result β := + match x with + | ret v => f v + | fail v => fail v + | div => div + +-- Allows using Result in do-blocks +instance : Bind Result where + bind := bind + +-- Allows using return x in do-blocks +instance : Pure Result where + pure := fun x => ret x + +@[simp] theorem bind_ret (x : α) (f : α → Result β) : bind (.ret x) f = f x := by simp [bind] +@[simp] theorem bind_fail (x : Error) (f : α → Result β) : bind (.fail x) f = .fail x := by simp [bind] +@[simp] theorem bind_div (f : α → Result β) : bind .div f = .div := by simp [bind] + +/- CUSTOM-DSL SUPPORT -/ + +-- Let-binding the Result of a monadic operation is oftentimes not sufficient, +-- because we may need a hypothesis for equational reasoning in the scope. We +-- rely on subtype, and a custom let-binding operator, in effect recreating our +-- own variant of the do-dsl + +def Result.attach {α: Type} (o : Result α): Result { x : α // o = ret x } := + match o with + | ret x => ret ⟨x, rfl⟩ + | fail e => fail e + | div => div + +@[simp] theorem bind_tc_ret (x : α) (f : α → Result β) : + (do let y ← .ret x; f y) = f x := by simp [Bind.bind, bind] + +@[simp] theorem bind_tc_fail (x : Error) (f : α → Result β) : + (do let y ← fail x; f y) = fail x := by simp [Bind.bind, bind] + +@[simp] theorem bind_tc_div (f : α → Result β) : + (do let y ← div; f y) = div := by simp [Bind.bind, bind] + +---------- +-- MISC -- +---------- + +@[simp] def mem.replace (a : Type) (x : a) (_ : a) : a := x +@[simp] def mem.replace_back (a : Type) (_ : a) (y : a) : a := y + +/-- Aeneas-translated function -- useful to reduce non-recursive definitions. + Use with `simp [ aeneas ]` -/ +register_simp_attr aeneas + +end Primitives diff --git a/backends/lean/Base/Primitives/Scalar.lean b/backends/lean/Base/Primitives/Scalar.lean new file mode 100644 index 00000000..241dfa07 --- /dev/null +++ b/backends/lean/Base/Primitives/Scalar.lean @@ -0,0 +1,507 @@ +import Lean +import Lean.Meta.Tactic.Simp +import Mathlib.Tactic.Linarith +import Base.Primitives.Base + +namespace Primitives + +---------------------- +-- MACHINE INTEGERS -- +---------------------- + +-- We redefine our machine integers types. + +-- For Isize/Usize, we reuse `getNumBits` from `USize`. You cannot reduce `getNumBits` +-- using the simplifier, meaning that proofs do not depend on the compile-time value of +-- USize.size. (Lean assumes 32 or 64-bit platforms, and Rust doesn't really support, at +-- least officially, 16-bit microcontrollers, so this seems like a fine design decision +-- for now.) + +-- Note from Chris Bailey: "If there's more than one salient property of your +-- definition then the subtyping strategy might get messy, and the property part +-- of a subtype is less discoverable by the simplifier or tactics like +-- library_search." So, we will not add refinements on the return values of the +-- operations defined on Primitives, but will rather rely on custom lemmas to +-- invert on possible return values of the primitive operations. + +-- Machine integer constants, done via `ofNatCore`, which requires a proof that +-- the `Nat` fits within the desired integer type. We provide a custom tactic. + +open Result Error +open System.Platform.getNumBits + +-- TODO: is there a way of only importing System.Platform.getNumBits? +-- +@[simp] def size_num_bits : Nat := (System.Platform.getNumBits ()).val + +-- Remark: Lean seems to use < for the comparisons with the upper bounds by convention. + +-- The "structured" bounds +def Isize.smin : Int := - (HPow.hPow 2 (size_num_bits - 1)) +def Isize.smax : Int := (HPow.hPow 2 (size_num_bits - 1)) - 1 +def I8.smin : Int := - (HPow.hPow 2 7) +def I8.smax : Int := HPow.hPow 2 7 - 1 +def I16.smin : Int := - (HPow.hPow 2 15) +def I16.smax : Int := HPow.hPow 2 15 - 1 +def I32.smin : Int := -(HPow.hPow 2 31) +def I32.smax : Int := HPow.hPow 2 31 - 1 +def I64.smin : Int := -(HPow.hPow 2 63) +def I64.smax : Int := HPow.hPow 2 63 - 1 +def I128.smin : Int := -(HPow.hPow 2 127) +def I128.smax : Int := HPow.hPow 2 127 - 1 +def Usize.smin : Int := 0 +def Usize.smax : Int := HPow.hPow 2 size_num_bits - 1 +def U8.smin : Int := 0 +def U8.smax : Int := HPow.hPow 2 8 - 1 +def U16.smin : Int := 0 +def U16.smax : Int := HPow.hPow 2 16 - 1 +def U32.smin : Int := 0 +def U32.smax : Int := HPow.hPow 2 32 - 1 +def U64.smin : Int := 0 +def U64.smax : Int := HPow.hPow 2 64 - 1 +def U128.smin : Int := 0 +def U128.smax : Int := HPow.hPow 2 128 - 1 + +-- The "normalized" bounds, that we use in practice +def I8.min := -128 +def I8.max := 127 +def I16.min := -32768 +def I16.max := 32767 +def I32.min := -2147483648 +def I32.max := 2147483647 +def I64.min := -9223372036854775808 +def I64.max := 9223372036854775807 +def I128.min := -170141183460469231731687303715884105728 +def I128.max := 170141183460469231731687303715884105727 +@[simp] def U8.min := 0 +def U8.max := 255 +@[simp] def U16.min := 0 +def U16.max := 65535 +@[simp] def U32.min := 0 +def U32.max := 4294967295 +@[simp] def U64.min := 0 +def U64.max := 18446744073709551615 +@[simp] def U128.min := 0 +def U128.max := 340282366920938463463374607431768211455 +@[simp] def Usize.min := 0 + +def Isize.refined_min : { n:Int // n = I32.min ∨ n = I64.min } := + ⟨ Isize.smin, by + simp [Isize.smin] + cases System.Platform.numBits_eq <;> + unfold System.Platform.numBits at * <;> simp [*] ⟩ + +def Isize.refined_max : { n:Int // n = I32.max ∨ n = I64.max } := + ⟨ Isize.smax, by + simp [Isize.smax] + cases System.Platform.numBits_eq <;> + unfold System.Platform.numBits at * <;> simp [*] ⟩ + +def Usize.refined_max : { n:Int // n = U32.max ∨ n = U64.max } := + ⟨ Usize.smax, by + simp [Usize.smax] + cases System.Platform.numBits_eq <;> + unfold System.Platform.numBits at * <;> simp [*] ⟩ + +def Isize.min := Isize.refined_min.val +def Isize.max := Isize.refined_max.val +def Usize.max := Usize.refined_max.val + +inductive ScalarTy := +| Isize +| I8 +| I16 +| I32 +| I64 +| I128 +| Usize +| U8 +| U16 +| U32 +| U64 +| U128 + +def Scalar.smin (ty : ScalarTy) : Int := + match ty with + | .Isize => Isize.smin + | .I8 => I8.smin + | .I16 => I16.smin + | .I32 => I32.smin + | .I64 => I64.smin + | .I128 => I128.smin + | .Usize => Usize.smin + | .U8 => U8.smin + | .U16 => U16.smin + | .U32 => U32.smin + | .U64 => U64.smin + | .U128 => U128.smin + +def Scalar.smax (ty : ScalarTy) : Int := + match ty with + | .Isize => Isize.smax + | .I8 => I8.smax + | .I16 => I16.smax + | .I32 => I32.smax + | .I64 => I64.smax + | .I128 => I128.smax + | .Usize => Usize.smax + | .U8 => U8.smax + | .U16 => U16.smax + | .U32 => U32.smax + | .U64 => U64.smax + | .U128 => U128.smax + +def Scalar.min (ty : ScalarTy) : Int := + match ty with + | .Isize => Isize.min + | .I8 => I8.min + | .I16 => I16.min + | .I32 => I32.min + | .I64 => I64.min + | .I128 => I128.min + | .Usize => Usize.min + | .U8 => U8.min + | .U16 => U16.min + | .U32 => U32.min + | .U64 => U64.min + | .U128 => U128.min + +def Scalar.max (ty : ScalarTy) : Int := + match ty with + | .Isize => Isize.max + | .I8 => I8.max + | .I16 => I16.max + | .I32 => I32.max + | .I64 => I64.max + | .I128 => I128.max + | .Usize => Usize.max + | .U8 => U8.max + | .U16 => U16.max + | .U32 => U32.max + | .U64 => U64.max + | .U128 => U128.max + +def Scalar.smin_eq (ty : ScalarTy) : Scalar.min ty = Scalar.smin ty := by + cases ty <;> rfl + +def Scalar.smax_eq (ty : ScalarTy) : Scalar.max ty = Scalar.smax ty := by + cases ty <;> rfl + +-- "Conservative" bounds +-- We use those because we can't compare to the isize bounds (which can't +-- reduce at compile-time). Whenever we perform an arithmetic operation like +-- addition we need to check that the result is in bounds: we first compare +-- to the conservative bounds, which reduce, then compare to the real bounds. +-- This is useful for the various #asserts that we want to reduce at +-- type-checking time. +def Scalar.cMin (ty : ScalarTy) : Int := + match ty with + | .Isize => Scalar.min .I32 + | _ => Scalar.min ty + +def Scalar.cMax (ty : ScalarTy) : Int := + match ty with + | .Isize => Scalar.max .I32 + | .Usize => Scalar.max .U32 + | _ => Scalar.max ty + +theorem Scalar.cMin_bound ty : Scalar.min ty ≤ Scalar.cMin ty := by + cases ty <;> simp [Scalar.min, Scalar.max, Scalar.cMin, Scalar.cMax] at * + have h := Isize.refined_min.property + cases h <;> simp [*, Isize.min] + +theorem Scalar.cMax_bound ty : Scalar.cMax ty ≤ Scalar.max ty := by + cases ty <;> simp [Scalar.min, Scalar.max, Scalar.cMin, Scalar.cMax] at * + . have h := Isize.refined_max.property + cases h <;> simp [*, Isize.max] + . have h := Usize.refined_max.property + cases h <;> simp [*, Usize.max] + +theorem Scalar.cMin_suffices ty (h : Scalar.cMin ty ≤ x) : Scalar.min ty ≤ x := by + have := Scalar.cMin_bound ty + linarith + +theorem Scalar.cMax_suffices ty (h : x ≤ Scalar.cMax ty) : x ≤ Scalar.max ty := by + have := Scalar.cMax_bound ty + linarith + +structure Scalar (ty : ScalarTy) where + val : Int + hmin : Scalar.min ty ≤ val + hmax : val ≤ Scalar.max ty +deriving Repr + +theorem Scalar.bound_suffices (ty : ScalarTy) (x : Int) : + Scalar.cMin ty ≤ x ∧ x ≤ Scalar.cMax ty -> + Scalar.min ty ≤ x ∧ x ≤ Scalar.max ty + := + λ h => by + apply And.intro <;> have hmin := Scalar.cMin_bound ty <;> have hmax := Scalar.cMax_bound ty <;> linarith + +def Scalar.ofIntCore {ty : ScalarTy} (x : Int) + (hmin : Scalar.min ty ≤ x) (hmax : x ≤ Scalar.max ty) : Scalar ty := + { val := x, hmin := hmin, hmax := hmax } + +-- Tactic to prove that integers are in bounds +-- TODO: use this: https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/instance.20with.20tactic.20autoparam +syntax "intlit" : tactic +macro_rules + | `(tactic| intlit) => `(tactic| apply Scalar.bound_suffices; decide) + +def Scalar.ofInt {ty : ScalarTy} (x : Int) + (h : Scalar.min ty ≤ x ∧ x ≤ Scalar.max ty := by intlit) : Scalar ty := + -- Remark: we initially wrote: + -- let ⟨ hmin, hmax ⟩ := h + -- Scalar.ofIntCore x hmin hmax + -- We updated to the line below because a similar pattern in `Scalar.tryMk` + -- made reduction block. Both versions seem to work for `Scalar.ofInt`, though. + -- TODO: investigate + Scalar.ofIntCore x h.left h.right + +@[simp] def Scalar.check_bounds (ty : ScalarTy) (x : Int) : Bool := + (Scalar.cMin ty ≤ x || Scalar.min ty ≤ x) ∧ (x ≤ Scalar.cMax ty || x ≤ Scalar.max ty) + +theorem Scalar.check_bounds_prop {ty : ScalarTy} {x : Int} (h: Scalar.check_bounds ty x) : + Scalar.min ty ≤ x ∧ x ≤ Scalar.max ty := by + simp at * + have ⟨ hmin, hmax ⟩ := h + have hbmin := Scalar.cMin_bound ty + have hbmax := Scalar.cMax_bound ty + cases hmin <;> cases hmax <;> apply And.intro <;> linarith + +-- Further thoughts: look at what has been done here: +-- https://github.com/leanprover-community/mathlib4/blob/master/Mathlib/Data/Fin/Basic.lean +-- and +-- https://github.com/leanprover-community/mathlib4/blob/master/Mathlib/Data/UInt.lean +-- which both contain a fair amount of reasoning already! +def Scalar.tryMk (ty : ScalarTy) (x : Int) : Result (Scalar ty) := + if h:Scalar.check_bounds ty x then + -- If we do: + -- ``` + -- let ⟨ hmin, hmax ⟩ := (Scalar.check_bounds_prop h) + -- Scalar.ofIntCore x hmin hmax + -- ``` + -- then normalization blocks (for instance, some proofs which use reflexivity fail). + -- However, the version below doesn't block reduction (TODO: investigate): + return Scalar.ofInt x (Scalar.check_bounds_prop h) + else fail integerOverflow + +def Scalar.neg {ty : ScalarTy} (x : Scalar ty) : Result (Scalar ty) := Scalar.tryMk ty (- x.val) + +def Scalar.div {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar ty) := + if y.val != 0 then Scalar.tryMk ty (x.val / y.val) else fail divisionByZero + +-- Our custom remainder operation, which satisfies the semantics of Rust +-- TODO: is there a better way? +def scalar_rem (x y : Int) : Int := + if 0 ≤ x then |x| % |y| + else - (|x| % |y|) + +-- Our custom division operation, which satisfies the semantics of Rust +-- TODO: is there a better way? +def scalar_div (x y : Int) : Int := + if 0 ≤ x && 0 ≤ y then |x| / |y| + else if 0 ≤ x && y < 0 then - (|x| / |y|) + else if x < 0 && 0 ≤ y then - (|x| / |y|) + else |x| / |y| + +-- Checking that the remainder operation is correct +#assert scalar_rem 1 2 = 1 +#assert scalar_rem (-1) 2 = -1 +#assert scalar_rem 1 (-2) = 1 +#assert scalar_rem (-1) (-2) = -1 +#assert scalar_rem 7 3 = (1:Int) +#assert scalar_rem (-7) 3 = -1 +#assert scalar_rem 7 (-3) = 1 +#assert scalar_rem (-7) (-3) = -1 + +-- Checking that the division operation is correct +#assert scalar_div 3 2 = 1 +#assert scalar_div (-3) 2 = -1 +#assert scalar_div 3 (-2) = -1 +#assert scalar_div (-3) (-2) = 1 +#assert scalar_div 7 3 = 2 +#assert scalar_div (-7) 3 = -2 +#assert scalar_div 7 (-3) = -2 +#assert scalar_div (-7) (-3) = 2 + +def Scalar.rem {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar ty) := + if y.val != 0 then Scalar.tryMk ty (x.val % y.val) else fail divisionByZero + +def Scalar.add {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar ty) := + Scalar.tryMk ty (x.val + y.val) + +def Scalar.sub {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar ty) := + Scalar.tryMk ty (x.val - y.val) + +def Scalar.mul {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar ty) := + Scalar.tryMk ty (x.val * y.val) + +-- TODO: instances of +, -, * etc. for scalars + +-- Cast an integer from a [src_ty] to a [tgt_ty] +-- TODO: check the semantics of casts in Rust +def Scalar.cast {src_ty : ScalarTy} (tgt_ty : ScalarTy) (x : Scalar src_ty) : Result (Scalar tgt_ty) := + Scalar.tryMk tgt_ty x.val + +-- The scalar types +-- We declare the definitions as reducible so that Lean can unfold them (useful +-- for type class resolution for instance). +@[reducible] def Isize := Scalar .Isize +@[reducible] def I8 := Scalar .I8 +@[reducible] def I16 := Scalar .I16 +@[reducible] def I32 := Scalar .I32 +@[reducible] def I64 := Scalar .I64 +@[reducible] def I128 := Scalar .I128 +@[reducible] def Usize := Scalar .Usize +@[reducible] def U8 := Scalar .U8 +@[reducible] def U16 := Scalar .U16 +@[reducible] def U32 := Scalar .U32 +@[reducible] def U64 := Scalar .U64 +@[reducible] def U128 := Scalar .U128 + +-- TODO: below: not sure this is the best way. +-- Should we rather overload operations like +, -, etc.? +-- Also, it is possible to automate the generation of those definitions +-- with macros (but would it be a good idea? It would be less easy to +-- read the file, which is not supposed to change a lot) + +-- Negation + +/-- +Remark: there is no heterogeneous negation in the Lean prelude: we thus introduce +one here. + +The notation typeclass for heterogeneous addition. +This enables the notation `- a : β` where `a : α`. +-/ +class HNeg (α : Type u) (β : outParam (Type v)) where + /-- `- a` computes the negation of `a`. + The meaning of this notation is type-dependent. -/ + hNeg : α → β + +prefix:75 "-" => HNeg.hNeg + +instance : HNeg Isize (Result Isize) where hNeg x := Scalar.neg x +instance : HNeg I8 (Result I8) where hNeg x := Scalar.neg x +instance : HNeg I16 (Result I16) where hNeg x := Scalar.neg x +instance : HNeg I32 (Result I32) where hNeg x := Scalar.neg x +instance : HNeg I64 (Result I64) where hNeg x := Scalar.neg x +instance : HNeg I128 (Result I128) where hNeg x := Scalar.neg x + +-- Addition +instance {ty} : HAdd (Scalar ty) (Scalar ty) (Result (Scalar ty)) where + hAdd x y := Scalar.add x y + +-- Substraction +instance {ty} : HSub (Scalar ty) (Scalar ty) (Result (Scalar ty)) where + hSub x y := Scalar.sub x y + +-- Multiplication +instance {ty} : HMul (Scalar ty) (Scalar ty) (Result (Scalar ty)) where + hMul x y := Scalar.mul x y + +-- Division +instance {ty} : HDiv (Scalar ty) (Scalar ty) (Result (Scalar ty)) where + hDiv x y := Scalar.div x y + +-- Remainder +instance {ty} : HMod (Scalar ty) (Scalar ty) (Result (Scalar ty)) where + hMod x y := Scalar.rem x y + +-- ofIntCore +-- TODO: typeclass? +def Isize.ofIntCore := @Scalar.ofIntCore .Isize +def I8.ofIntCore := @Scalar.ofIntCore .I8 +def I16.ofIntCore := @Scalar.ofIntCore .I16 +def I32.ofIntCore := @Scalar.ofIntCore .I32 +def I64.ofIntCore := @Scalar.ofIntCore .I64 +def I128.ofIntCore := @Scalar.ofIntCore .I128 +def Usize.ofIntCore := @Scalar.ofIntCore .Usize +def U8.ofIntCore := @Scalar.ofIntCore .U8 +def U16.ofIntCore := @Scalar.ofIntCore .U16 +def U32.ofIntCore := @Scalar.ofIntCore .U32 +def U64.ofIntCore := @Scalar.ofIntCore .U64 +def U128.ofIntCore := @Scalar.ofIntCore .U128 + +-- ofInt +-- TODO: typeclass? +def Isize.ofInt := @Scalar.ofInt .Isize +def I8.ofInt := @Scalar.ofInt .I8 +def I16.ofInt := @Scalar.ofInt .I16 +def I32.ofInt := @Scalar.ofInt .I32 +def I64.ofInt := @Scalar.ofInt .I64 +def I128.ofInt := @Scalar.ofInt .I128 +def Usize.ofInt := @Scalar.ofInt .Usize +def U8.ofInt := @Scalar.ofInt .U8 +def U16.ofInt := @Scalar.ofInt .U16 +def U32.ofInt := @Scalar.ofInt .U32 +def U64.ofInt := @Scalar.ofInt .U64 +def U128.ofInt := @Scalar.ofInt .U128 + +-- Comparisons +instance {ty} : LT (Scalar ty) where + lt a b := LT.lt a.val b.val + +instance {ty} : LE (Scalar ty) where le a b := LE.le a.val b.val + +instance Scalar.decLt {ty} (a b : Scalar ty) : Decidable (LT.lt a b) := Int.decLt .. +instance Scalar.decLe {ty} (a b : Scalar ty) : Decidable (LE.le a b) := Int.decLe .. + +theorem Scalar.eq_of_val_eq {ty} : ∀ {i j : Scalar ty}, Eq i.val j.val → Eq i j + | ⟨_, _, _⟩, ⟨_, _, _⟩, rfl => rfl + +theorem Scalar.val_eq_of_eq {ty} {i j : Scalar ty} (h : Eq i j) : Eq i.val j.val := + h ▸ rfl + +theorem Scalar.ne_of_val_ne {ty} {i j : Scalar ty} (h : Not (Eq i.val j.val)) : Not (Eq i j) := + fun h' => absurd (val_eq_of_eq h') h + +instance (ty : ScalarTy) : DecidableEq (Scalar ty) := + fun i j => + match decEq i.val j.val with + | isTrue h => isTrue (Scalar.eq_of_val_eq h) + | isFalse h => isFalse (Scalar.ne_of_val_ne h) + +/- Remark: we can't write the following instance because of restrictions about + the type class parameters (`ty` doesn't appear in the return type, which is + forbidden): + + ``` + instance Scalar.cast (ty : ScalarTy) : Coe (Scalar ty) Int where coe := λ v => v.val + ``` + -/ +def Scalar.toInt {ty} (n : Scalar ty) : Int := n.val + +-- -- We now define a type class that subsumes the various machine integer types, so +-- -- as to write a concise definition for scalar_cast, rather than exhaustively +-- -- enumerating all of the possible pairs. We remark that Rust has sane semantics +-- -- and fails if a cast operation would involve a truncation or modulo. + +-- class MachineInteger (t: Type) where +-- size: Nat +-- val: t -> Fin size +-- ofNatCore: (n:Nat) -> LT.lt n size -> t + +-- set_option hygiene false in +-- run_cmd +-- for typeName in [`UInt8, `UInt16, `UInt32, `UInt64, `USize].map Lean.mkIdent do +-- Lean.Elab.Command.elabCommand (← `( +-- namespace $typeName +-- instance: MachineInteger $typeName where +-- size := size +-- val := val +-- ofNatCore := ofNatCore +-- end $typeName +-- )) + +-- -- Aeneas only instantiates the destination type (`src` is implicit). We rely on +-- -- Lean to infer `src`. + +-- def scalar_cast { src: Type } (dst: Type) [ MachineInteger src ] [ MachineInteger dst ] (x: src): Result dst := +-- if h: MachineInteger.val x < MachineInteger.size dst then +-- .ret (MachineInteger.ofNatCore (MachineInteger.val x).val h) +-- else +-- .fail integerOverflow + +end Primitives diff --git a/backends/lean/Base/Primitives/Vec.lean b/backends/lean/Base/Primitives/Vec.lean new file mode 100644 index 00000000..7851a232 --- /dev/null +++ b/backends/lean/Base/Primitives/Vec.lean @@ -0,0 +1,113 @@ +import Lean +import Lean.Meta.Tactic.Simp +import Init.Data.List.Basic +import Mathlib.Tactic.RunCmd +import Mathlib.Tactic.Linarith +import Base.IList +import Base.Primitives.Scalar +import Base.Arith + +namespace Primitives + +open Result Error + +------------- +-- VECTORS -- +------------- + +def Vec (α : Type u) := { l : List α // List.length l ≤ Usize.max } + +-- TODO: do we really need it? It should be with Subtype by default +instance Vec.cast (a : Type): Coe (Vec a) (List a) where coe := λ v => v.val + +instance (a : Type) : Arith.HasIntProp (Vec a) where + prop_ty := λ v => v.val.length ≤ Scalar.max ScalarTy.Usize + prop := λ ⟨ _, l ⟩ => l + +example {a: Type} (v : Vec a) : v.val.length ≤ Scalar.max ScalarTy.Usize := by + intro_has_int_prop_instances + simp_all [Scalar.max, Scalar.min] + +example {a: Type} (v : Vec a) : v.val.length ≤ Scalar.max ScalarTy.Usize := by + scalar_tac + +def Vec.new (α : Type u): Vec α := ⟨ [], by apply Scalar.cMax_suffices .Usize; simp ⟩ + +def Vec.len (α : Type u) (v : Vec α) : Usize := + let ⟨ v, l ⟩ := v + Usize.ofIntCore (List.length v) (by simp [Scalar.min, Usize.min]) l + +def Vec.length {α : Type u} (v : Vec α) : Int := v.val.len + +-- This shouldn't be used +def Vec.push_fwd (α : Type u) (_ : Vec α) (_ : α) : Unit := () + +-- This is actually the backward function +def Vec.push (α : Type u) (v : Vec α) (x : α) : Result (Vec α) + := + let nlen := List.length v.val + 1 + if h : nlen ≤ U32.max || nlen ≤ Usize.max then + have h : nlen ≤ Usize.max := by + simp [Usize.max] at * + have hm := Usize.refined_max.property + cases h <;> cases hm <;> simp [U32.max, U64.max] at * <;> try linarith + return ⟨ List.concat v.val x, by simp at *; assumption ⟩ + else + fail maximumSizeExceeded + +-- This shouldn't be used +def Vec.insert_fwd (α : Type u) (v: Vec α) (i: Usize) (_: α): Result Unit := + if i.val < List.length v.val then + .ret () + else + .fail arrayOutOfBounds + +-- This is actually the backward function +def Vec.insert (α : Type u) (v: Vec α) (i: Usize) (x: α): Result (Vec α) := + if i.val < List.length v.val then + -- TODO: maybe we should redefine a list library which uses integers + -- (instead of natural numbers) + .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ + else + .fail arrayOutOfBounds + +-- TODO: remove +def Vec.index_to_fin {α : Type u} {v: Vec α} {i: Usize} (h : i.val < List.length v.val) : + Fin (List.length v.val) := + let j := i.val.toNat + let h: j < List.length v.val := by + have heq := @Int.toNat_lt (List.length v.val) i.val i.hmin + apply heq.mpr + assumption + ⟨j, h⟩ + +def Vec.index (α : Type u) (v: Vec α) (i: Usize): Result α := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some x => ret x + +-- This shouldn't be used +def Vec.index_back (α : Type u) (v: Vec α) (i: Usize) (_: α): Result Unit := + if i.val < List.length v.val then + .ret () + else + .fail arrayOutOfBounds + +def Vec.index_mut (α : Type u) (v: Vec α) (i: Usize): Result α := + if h: i.val < List.length v.val then + let i := Vec.index_to_fin h + .ret (List.get v.val i) + else + .fail arrayOutOfBounds + +def Vec.index_mut_back (α : Type u) (v: Vec α) (i: Usize) (x: α): Result (Vec α) := + if h: i.val < List.length v.val then + let i := Vec.index_to_fin h + .ret ⟨ List.set v.val i x, by + have h: List.length v.val ≤ Usize.max := v.property + simp [*] at * + ⟩ + else + .fail arrayOutOfBounds + +end Primitives diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 35a3c25a..af7b426a 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -7,6 +7,7 @@ namespace Progress open Lean Elab Term Meta Tactic open Utils +-- TODO: remove namespace Test open Primitives @@ -199,6 +200,7 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do elab "progress" args:progressArgs : tactic => evalProgress args +-- TODO: remove namespace Test open Primitives -- cgit v1.3.1 From 2fa3cb8ee04dd7ff4184e3e1000fdc025abc50a4 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 17 Jul 2023 23:37:48 +0200 Subject: Start proving theorems for primitive definitions --- backends/lean/Base/Diverge/Base.lean | 3 +- backends/lean/Base/IList/IList.lean | 66 ++++++++++++++++++----- backends/lean/Base/Primitives/Scalar.lean | 1 + backends/lean/Base/Primitives/Vec.lean | 89 +++++++++++++++++++------------ backends/lean/Base/Progress/Base.lean | 3 +- backends/lean/Base/Progress/Progress.lean | 4 ++ 6 files changed, 116 insertions(+), 50 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Diverge/Base.lean b/backends/lean/Base/Diverge/Base.lean index 0a9ea4c4..4ff1d923 100644 --- a/backends/lean/Base/Diverge/Base.lean +++ b/backends/lean/Base/Diverge/Base.lean @@ -3,8 +3,7 @@ import Lean.Meta.Tactic.Simp import Init.Data.List.Basic import Mathlib.Tactic.RunCmd import Mathlib.Tactic.Linarith - -import Base.Primitives +import Base.Primitives.Base /- TODO: this is very useful, but is there more? -/ set_option profiler true diff --git a/backends/lean/Base/IList/IList.lean b/backends/lean/Base/IList/IList.lean index 2a335cac..ddb10236 100644 --- a/backends/lean/Base/IList/IList.lean +++ b/backends/lean/Base/IList/IList.lean @@ -11,12 +11,27 @@ def len (ls : List α) : Int := | [] => 0 | _ :: tl => 1 + len tl +@[simp] theorem len_nil : len ([] : List α) = 0 := by simp [len] +@[simp] theorem len_cons : len ((x :: tl) : List α) = 1 + len tl := by simp [len] + +theorem len_pos : 0 ≤ (ls : List α).len := by + induction ls <;> simp [*] + linarith + +instance (a : Type u) : Arith.HasIntProp (List a) where + prop_ty := λ ls => 0 ≤ ls.len + prop := λ ls => ls.len_pos + -- Remark: if i < 0, then the result is none def indexOpt (ls : List α) (i : Int) : Option α := match ls with | [] => none | hd :: tl => if i = 0 then some hd else indexOpt tl (i - 1) +@[simp] theorem indexOpt_nil : indexOpt ([] : List α) i = none := by simp [indexOpt] +@[simp] theorem indexOpt_zero_cons : indexOpt ((x :: tl) : List α) 0 = some x := by simp [indexOpt] +@[simp] theorem indexOpt_nzero_cons (hne : i ≠ 0) : indexOpt ((x :: tl) : List α) i = indexOpt tl (i - 1) := by simp [*, indexOpt] + -- Remark: if i < 0, then the result is the defaul element def index [Inhabited α] (ls : List α) (i : Int) : α := match ls with @@ -24,6 +39,43 @@ def index [Inhabited α] (ls : List α) (i : Int) : α := | x :: tl => if i = 0 then x else index tl (i - 1) +@[simp] theorem index_zero_cons [Inhabited α] : index ((x :: tl) : List α) 0 = x := by simp [index] +@[simp] theorem index_nzero_cons [Inhabited α] (hne : i ≠ 0) : index ((x :: tl) : List α) i = index tl (i - 1) := by simp [*, index] + +theorem indexOpt_bounds (ls : List α) (i : Int) : + ls.indexOpt i = none ↔ i < 0 ∨ ls.len ≤ i := + match ls with + | [] => + have : ¬ (i < 0) → 0 ≤ i := by intro; linarith -- TODO: simplify (we could boost int_tac) + by simp; tauto + | _ :: tl => + have := indexOpt_bounds tl (i - 1) + if h: i = 0 then + by + simp [*]; + -- TODO: int_tac/scalar_tac should also explore the goal! + have := tl.len_pos + linarith + else by + simp [*] + constructor <;> intros <;> + -- TODO: tactic to split all disjunctions + rename_i hor <;> cases hor <;> + first | left; int_tac | right; int_tac + +theorem indexOpt_eq_index [Inhabited α] (ls : List α) (i : Int) : + 0 ≤ i → + i < ls.len → + ls.indexOpt i = some (ls.index i) := + match ls with + | [] => by simp; intros; linarith + | hd :: tl => + if h: i = 0 then + by simp [*] + else + have hi := indexOpt_eq_index tl (i - 1) + by simp [*]; intros; apply hi <;> int_tac + -- Remark: the list is unchanged if the index is not in bounds (in particular -- if it is < 0) def update (ls : List α) (i : Int) (y : α) : List α := @@ -42,12 +94,6 @@ section Lemmas variable {α : Type u} -@[simp] theorem len_nil : len ([] : List α) = 0 := by simp [len] -@[simp] theorem len_cons : len ((x :: tl) : List α) = 1 + len tl := by simp [len] - -@[simp] theorem index_zero_cons [Inhabited α] : index ((x :: tl) : List α) 0 = x := by simp [index] -@[simp] theorem index_nzero_cons [Inhabited α] (hne : i ≠ 0) : index ((x :: tl) : List α) i = index tl (i - 1) := by simp [*, index] - @[simp] theorem update_nil : update ([] : List α) i y = [] := by simp [update] @[simp] theorem update_zero_cons : update ((x :: tl) : List α) 0 y = y :: tl := by simp [update] @[simp] theorem update_nzero_cons (hne : i ≠ 0) : update ((x :: tl) : List α) i y = x :: update tl (i - 1) y := by simp [*, update] @@ -81,14 +127,6 @@ theorem len_update (ls : List α) (i : Int) (x : α) : (ls.update i x).len = ls. simp [len_eq_length] -theorem len_pos : 0 ≤ (ls : List α).len := by - induction ls <;> simp [*] - linarith - -instance (a : Type u) : Arith.HasIntProp (List a) where - prop_ty := λ ls => 0 ≤ ls.len - prop := λ ls => ls.len_pos - theorem left_length_eq_append_eq (l1 l2 l1' l2' : List α) (heq : l1.length = l1'.length) : l1 ++ l2 = l1' ++ l2' ↔ l1 = l1' ∧ l2 = l2' := by revert l1' diff --git a/backends/lean/Base/Primitives/Scalar.lean b/backends/lean/Base/Primitives/Scalar.lean index 241dfa07..3f88caa2 100644 --- a/backends/lean/Base/Primitives/Scalar.lean +++ b/backends/lean/Base/Primitives/Scalar.lean @@ -2,6 +2,7 @@ import Lean import Lean.Meta.Tactic.Simp import Mathlib.Tactic.Linarith import Base.Primitives.Base +import Base.Diverge.Base namespace Primitives diff --git a/backends/lean/Base/Primitives/Vec.lean b/backends/lean/Base/Primitives/Vec.lean index 7851a232..4ecfa28f 100644 --- a/backends/lean/Base/Primitives/Vec.lean +++ b/backends/lean/Base/Primitives/Vec.lean @@ -6,6 +6,7 @@ import Mathlib.Tactic.Linarith import Base.IList import Base.Primitives.Scalar import Base.Arith +import Base.Progress.Base namespace Primitives @@ -56,58 +57,80 @@ def Vec.push (α : Type u) (v : Vec α) (x : α) : Result (Vec α) fail maximumSizeExceeded -- This shouldn't be used -def Vec.insert_fwd (α : Type u) (v: Vec α) (i: Usize) (_: α): Result Unit := - if i.val < List.length v.val then +def Vec.insert_fwd (α : Type u) (v: Vec α) (i: Usize) (_: α) : Result Unit := + if i.val < v.length then .ret () else .fail arrayOutOfBounds -- This is actually the backward function -def Vec.insert (α : Type u) (v: Vec α) (i: Usize) (x: α): Result (Vec α) := - if i.val < List.length v.val then - -- TODO: maybe we should redefine a list library which uses integers - -- (instead of natural numbers) +def Vec.insert (α : Type u) (v: Vec α) (i: Usize) (x: α) : Result (Vec α) := + if i.val < v.length then .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ else .fail arrayOutOfBounds --- TODO: remove -def Vec.index_to_fin {α : Type u} {v: Vec α} {i: Usize} (h : i.val < List.length v.val) : - Fin (List.length v.val) := - let j := i.val.toNat - let h: j < List.length v.val := by - have heq := @Int.toNat_lt (List.length v.val) i.val i.hmin - apply heq.mpr - assumption - ⟨j, h⟩ - -def Vec.index (α : Type u) (v: Vec α) (i: Usize): Result α := +@[pspec] +theorem Vec.insert_spec {α : Type u} (v: Vec α) (i: Usize) (x: α) : + i.val < v.length → + ∃ nv, v.insert α i x = ret nv ∧ nv.val = v.val.update i.val x := by + intro h + simp [insert, *] + +def Vec.index (α : Type u) (v: Vec α) (i: Usize) : Result α := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some x => ret x +@[pspec] +theorem Vec.index_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) : + i.val < v.length → + v.index α i = ret (v.val.index i.val) := by + intro + simp only [index] + -- TODO: dependent rewrite + have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp[length] at *; simp [*]) + simp only [*] + -- This shouldn't be used -def Vec.index_back (α : Type u) (v: Vec α) (i: Usize) (_: α): Result Unit := +def Vec.index_back (α : Type u) (v: Vec α) (i: Usize) (_: α) : Result Unit := if i.val < List.length v.val then .ret () else .fail arrayOutOfBounds -def Vec.index_mut (α : Type u) (v: Vec α) (i: Usize): Result α := - if h: i.val < List.length v.val then - let i := Vec.index_to_fin h - .ret (List.get v.val i) - else - .fail arrayOutOfBounds +def Vec.index_mut (α : Type u) (v: Vec α) (i: Usize) : Result α := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some x => ret x -def Vec.index_mut_back (α : Type u) (v: Vec α) (i: Usize) (x: α): Result (Vec α) := - if h: i.val < List.length v.val then - let i := Vec.index_to_fin h - .ret ⟨ List.set v.val i x, by - have h: List.length v.val ≤ Usize.max := v.property - simp [*] at * - ⟩ - else - .fail arrayOutOfBounds +@[pspec] +theorem Vec.index_mut_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) : + i.val < v.length → + v.index_mut α i = ret (v.val.index i.val) := by + intro + simp only [index_mut] + -- TODO: dependent rewrite + have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp[length] at *; simp [*]) + simp only [*] + +def Vec.index_mut_back (α : Type u) (v: Vec α) (i: Usize) (x: α) : Result (Vec α) := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some _ => + .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ + +@[pspec] +theorem Vec.index_mut_back_spec {α : Type u} (v: Vec α) (i: Usize) (x : α) : + i.val < v.length → + ∃ nv, v.index_mut_back α i x = ret nv ∧ + nv.val = v.val.update i.val x + := by + intro + simp only [index_mut_back] + have h := List.indexOpt_bounds v.val i.val + split + . simp_all [length]; cases h <;> scalar_tac + . simp_all end Primitives diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index a288d889..00b0a478 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -1,6 +1,7 @@ import Lean +import Std.Lean.HashSet import Base.Utils -import Base.Primitives +import Base.Primitives.Base namespace Progress diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index af7b426a..001967e5 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -7,6 +7,7 @@ namespace Progress open Lean Elab Term Meta Tactic open Utils +/- -- TODO: remove namespace Test open Primitives @@ -20,6 +21,7 @@ namespace Test #eval pspecAttr.find? ``Primitives.Vec.index end Test +-/ inductive TheoremOrLocal where | Theorem (thName : Name) @@ -200,6 +202,7 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do elab "progress" args:progressArgs : tactic => evalProgress args +/- -- TODO: remove namespace Test open Primitives @@ -215,5 +218,6 @@ namespace Test set_option trace.Progress false end Test +-/ end Progress -- cgit v1.3.1 From e07177ee2de3fd1346ab6b1fc09aefbcb0e24459 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 18 Jul 2023 12:22:59 +0200 Subject: Improve progress --- backends/lean/Base/Progress/Base.lean | 11 ++++++++--- backends/lean/Base/Progress/Progress.lean | 11 +++++++++-- backends/lean/Base/Utils.lean | 4 ++++ tests/lean/Hashmap/Properties.lean | 24 +++++++++++------------- 4 files changed, 32 insertions(+), 18 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index 00b0a478..7eace667 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -58,10 +58,10 @@ section Methods def withPSpec [Inhabited (m a)] [Nonempty (m a)] (th : Expr) (k : PSpecDesc → m a) (sanityChecks : Bool := false) : m a := do - trace[Progress] "Theorem: {th}" + trace[Progress] "Proposition: {th}" -- Dive into the quantified variables and the assumptions forallTelescope th fun fvars th => do - trace[Progress] "All arguments: {fvars}" + trace[Progress] "Universally quantified arguments and assumptions: {fvars}" /- -- Filter the argumens which are not propositions let rec getFirstPropIdx (i : Nat) : MetaM Nat := do if i ≥ fargs.size then pure i @@ -83,12 +83,16 @@ section Methods -- Dive into the existentials existsTelescope th fun evars th => do trace[Progress] "Existentials: {evars}" + trace[Progress] "Proposition after stripping the quantifiers: {th}" -- Take the first conjunct let (th, post) ← optSplitConj th + trace[Progress] "After splitting the conjunction:\n- eq: {th}\n- post: {post}" -- Destruct the equality let (th, ret) ← destEq th + trace[Progress] "After splitting the equality:\n- lhs: {th}\n- rhs: {ret}" -- Destruct the application to get the name - th.withApp fun f args => do + th.consumeMData.withApp fun f args => do + trace[Progress] "After stripping the arguments:\n- f: {f}\n- args: {args}" if ¬ f.isConst then throwError "Not a constant: {f}" -- Compute the set of universally quantified variables which appear in the function arguments let allArgsFVars ← args.foldlM (fun hs arg => getFVarIds arg hs) HashSet.empty @@ -114,6 +118,7 @@ section Methods post := post } k thDesc + end Methods diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 001967e5..ace92f4f 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -55,14 +55,20 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) let thDecl := env.constants.find! thName pure thDecl.type | .Local asmDecl => pure asmDecl.type + trace[Progress] "theorem/assumption type: {thTy}" -- TODO: the tactic fails if we uncomment withNewMCtxDepth -- withNewMCtxDepth do let (mvars, binders, thExBody) ← forallMetaTelescope thTy + trace[Progress] "After stripping foralls: {thExBody}" -- Introduce the existentially quantified variables and the post-condition -- in the context let thBody ← existsTelescope thExBody fun _evars thBody => do + trace[Progress] "After stripping existentials: {thBody}" + let (thBody, _) ← optSplitConj thBody + trace[Progress] "After splitting the conjunction: {thBody}" let (thBody, _) ← destEq thBody + trace[Progress] "After splitting equality: {thBody}" -- There shouldn't be any existential variables in thBody pure thBody -- Match the body with the target @@ -152,6 +158,7 @@ def progressAsmsOrLookupTheorem (ids : Array Name) (asmTac : TacticM Unit) : Tac -- Retrieve the goal let mgoal ← Tactic.getMainGoal let goalTy ← mgoal.getType + trace[Progress] "goal: {goalTy}" -- Dive into the goal to lookup the theorem let (fName, fLevels, args) ← do withPSpec goalTy fun desc => @@ -188,7 +195,7 @@ syntax progressArgs := ("as" " ⟨ " (ident)+ " ⟩")? def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do let args := args.raw -- Process the arguments to retrieve the identifiers to use - trace[Progress] "Progressing arguments: {args}" + trace[Progress] "Progress arguments: {args}" let args := args.getArgs let ids := if args.size > 0 then @@ -196,7 +203,7 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do let args := (args.get! 2).getArgs args.map Syntax.getId else #[] - trace[Progress] "Ids: {ids}" + trace[Progress] "User-provided ids: {ids}" progressAsmsOrLookupTheorem ids (firstTac [assumptionTac, Arith.scalarTac]) elab "progress" args:progressArgs : tactic => diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index 599c3a9f..9cd0db23 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -43,6 +43,10 @@ namespace List end List +-- TODO: move? +@[simp] +theorem neq_imp {α : Type u} {x y : α} (h : ¬ x = y) : ¬ y = x := by intro; simp_all + namespace Lean namespace LocalContext diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index 1db39422..ee22bebd 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -105,6 +105,8 @@ theorem insert_in_list_spec {α : Type} (key: Usize) (value: α) (ls: List α) : simp [h] else by + -- TODO: use progress: detect that this is a recursive call, or give + -- the possibility of specifying an identifier have ⟨ b, hi ⟩ := insert_in_list_spec key value tl exists b simp [insert_in_list, List.lookup] @@ -112,13 +114,12 @@ theorem insert_in_list_spec {α : Type} (key: Usize) (value: α) (ls: List α) : simp [h] simp [insert_in_list] at hi exact hi - -/-- + @[pspec] theorem insert_in_list_spec2 {α : Type} (key: Usize) (value: α) (ls: List α) : ∃ b, insert_in_list α key value ls = ret b ∧ - (b = (List.lookup ls.v key = none)) + (b ↔ (List.lookup ls.v key = none)) := by induction ls case Nil => simp [insert_in_list, insert_in_list_loop, List.lookup] @@ -130,11 +131,12 @@ theorem insert_in_list_spec2 {α : Type} (key: Usize) (value: α) (ls: List α) simp [h] else conv => - rhs; ext; arg 1; simp [h] -- TODO: Simplify - simp [insert_in_list] at ih; - progress -- TODO: Does not work ---/ - + rhs; ext; left; simp [h] -- TODO: Simplify + simp only [insert_in_list] at ih; + -- TODO: give the possibility of using underscores + progress as ⟨ b h ⟩ + simp [*] + @[pspec] theorem insert_in_list_back_spec {α : Type} (key: Usize) (value: α) (l0: List α) : ∃ l1, @@ -150,8 +152,7 @@ theorem insert_in_list_back_spec {α : Type} (key: Usize) (value: α) (l0: List rw [insert_in_list_loop_back] simp [h, List.lookup] intro k1 h1 - have h2 : ¬(key = k1) := by tauto -- TODO: Why is the order of args in eq swapped - simp [h2] + simp [*] else by simp [insert_in_list_back, List.lookup] @@ -159,12 +160,9 @@ theorem insert_in_list_back_spec {α : Type} (key: Usize) (value: α) (l0: List simp [h, List.lookup] have ⟨tl0 , _, _ ⟩ := insert_in_list_back_spec key value tl -- TODO: Use progress simp [insert_in_list_back] at * - simp [*] - have : ¬ (key = k) := by tauto simp [List.lookup, *] simp (config := {contextual := true}) [*] end HashMap --- def distinct_keys {α : Type u} end hashmap -- cgit v1.3.1 From 204742bf2449c88abaea8ebd284c55d98b43488a Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 19 Jul 2023 14:48:08 +0200 Subject: Improve progress --- backends/lean/Base/Arith/Int.lean | 8 --- backends/lean/Base/Progress/Progress.lean | 115 +++++++++++++++++++++--------- backends/lean/Base/Utils.lean | 19 +++++ tests/lean/Hashmap/Properties.lean | 34 ++++++++- 4 files changed, 131 insertions(+), 45 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Arith/Int.lean b/backends/lean/Base/Arith/Int.lean index 5f00ab52..ac011998 100644 --- a/backends/lean/Base/Arith/Int.lean +++ b/backends/lean/Base/Arith/Int.lean @@ -32,14 +32,6 @@ instance (x y : Int) : PropHasImp (¬ x = y) where open Lean Lean.Elab Lean.Meta --- Small utility: print all the declarations in the context -elab "print_all_decls" : tactic => do - let ctx ← Lean.MonadLCtx.getLCtx - for decl in ← ctx.getDecls do - let ty ← Lean.Meta.inferType decl.toExpr - logInfo m!"{decl.toExpr} : {ty}" - pure () - -- Explore a term by decomposing the applications (we explore the applied -- functions and their arguments, but ignore lambdas, forall, etc. - -- should we go inside?). diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index ace92f4f..3b0248fe 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -55,7 +55,7 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) let thDecl := env.constants.find! thName pure thDecl.type | .Local asmDecl => pure asmDecl.type - trace[Progress] "theorem/assumption type: {thTy}" + trace[Progress] "Looked up theorem/assumption type: {thTy}" -- TODO: the tactic fails if we uncomment withNewMCtxDepth -- withNewMCtxDepth do let (mvars, binders, thExBody) ← forallMetaTelescope thTy @@ -84,7 +84,7 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) let th ← do match th with | .Theorem thName => mkAppOptM thName (mvars.map some) - | .Local decl => mkAppOptM' (mkFVar decl.fvarId) (mvars.map some) + | .Local decl => mkAppOptM' (mkFVar decl.fvarId) (mvars.map some) let asmName ← mkFreshUserName `h let thTy ← inferType th let thAsm ← Utils.addDeclTac asmName th thTy (asLet := false) @@ -153,7 +153,7 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) pure .Ok -- The array of ids are identifiers to use when introducing fresh variables -def progressAsmsOrLookupTheorem (ids : Array Name) (asmTac : TacticM Unit) : TacticM Unit := do +def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Name) (asmTac : TacticM Unit) : TacticM Unit := do withMainContext do -- Retrieve the goal let mgoal ← Tactic.getMainGoal @@ -167,44 +167,89 @@ def progressAsmsOrLookupTheorem (ids : Array Name) (asmTac : TacticM Unit) : Tac -- TODO: this should be in the pspec desc let fnExpr := mkAppN (.const fName fLevels) args trace[Progress] "Function: {fName}" - -- Try all the assumptions one by one and if it fails try to lookup a theorem - let ctx ← Lean.MonadLCtx.getLCtx - let decls ← ctx.getDecls - for decl in decls.reverse do - trace[Progress] "Trying assumption: {decl.userName} : {decl.type}" - try - match ← progressWith fnExpr (.Local decl) ids asmTac with + -- If the user provided a theorem/assumption: use it. + -- Otherwise, lookup one. + match withTh with + | some th => do + match ← progressWith fnExpr th ids asmTac with + | .Ok => return () + | .Error msg => throwError msg + | none => + -- Try all the assumptions one by one and if it fails try to lookup a theorem. + let ctx ← Lean.MonadLCtx.getLCtx + let decls ← ctx.getDecls + for decl in decls.reverse do + trace[Progress] "Trying assumption: {decl.userName} : {decl.type}" + let res ← do try progressWith fnExpr (.Local decl) ids asmTac catch _ => continue + match res with | .Ok => return () | .Error msg => throwError msg - catch _ => continue - -- It failed: try to lookup a theorem - -- TODO: use a list of theorems, and try them one by one? - trace[Progress] "No assumption succeeded: trying to lookup a theorem" - let thName ← do - match ← pspecAttr.find? fName with - | none => throwError "Could not find a pspec theorem for {fName}" - | some thName => pure thName - trace[Progress] "Lookuped up: {thName}" - -- Apply the theorem - match ← progressWith fnExpr (.Theorem thName) ids asmTac with - | .Ok => return () - | .Error msg => throwError msg - -syntax progressArgs := ("as" " ⟨ " (ident)+ " ⟩")? + -- It failed: try to lookup a theorem + -- TODO: use a list of theorems, and try them one by one? + trace[Progress] "No assumption succeeded: trying to lookup a theorem" + let thName ← do + match ← pspecAttr.find? fName with + | none => throwError "Could not find a pspec theorem for {fName}" + | some thName => pure thName + trace[Progress] "Lookuped up theorem: {thName}" + -- Apply the theorem + let res ← do + try + let res ← progressWith fnExpr (.Theorem thName) ids asmTac + pure (some res) + catch _ => none + match res with + | some .Ok => return () + | some (.Error msg) => throwError msg + | none => + -- Try a recursive call - we try the assumptions of kind "auxDecl" + let ctx ← Lean.MonadLCtx.getLCtx + let decls ← ctx.getAllDecls + let decls := decls.filter (λ decl => match decl.kind with + | .default | .implDetail => false | .auxDecl => true) + for decl in decls.reverse do + trace[Progress] "Trying recursive assumption: {decl.userName} : {decl.type}" + let res ← do try progressWith fnExpr (.Local decl) ids asmTac catch _ => continue + match res with + | .Ok => return () + | .Error msg => throwError msg + -- Nothing worked: failed + throwError "Progress failed" + +syntax progressArgs := ("with" ident)? ("as" " ⟨ " (ident)+ " ⟩")? +#check Environment +#check ConstMap def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do let args := args.raw -- Process the arguments to retrieve the identifiers to use trace[Progress] "Progress arguments: {args}" let args := args.getArgs - let ids := - if args.size > 0 then - let args := (args.get! 0).getArgs - let args := (args.get! 2).getArgs - args.map Syntax.getId - else #[] + let withArg := (args.get! 0).getArgs + let withArg ← do + if withArg.size > 0 then + let id := withArg.get! 1 + trace[Progress] "With arg: {id}" + -- Attempt to lookup a local declaration + match (← getLCtx).findFromUserName? id.getId with + | some decl => do + trace[Progress] "With arg: local decl" + pure (some (.Local decl)) + | none => do + -- Not a local declaration: should be a theorem + trace[Progress] "With arg: theorem" + addCompletionInfo <| CompletionInfo.id id id.getId (danglingDot := false) {} none + let cs ← resolveGlobalConstWithInfos id + match cs with + | [] => throwError "Could not find theorem {id}" + | id :: _ => + pure (some (.Theorem id)) + else pure none + let args := (args.get! 1).getArgs + let args := (args.get! 2).getArgs + let ids := args.map Syntax.getId trace[Progress] "User-provided ids: {ids}" - progressAsmsOrLookupTheorem ids (firstTac [assumptionTac, Arith.scalarTac]) + progressAsmsOrLookupTheorem withArg ids (firstTac [assumptionTac, Arith.scalarTac]) elab "progress" args:progressArgs : tactic => evalProgress args @@ -215,16 +260,16 @@ namespace Test open Primitives set_option trace.Progress true + set_option pp.rawOnError true @[pspec] theorem vec_index_test2 (α : Type u) (v: Vec α) (i: Usize) (h: i.val < v.val.length) : ∃ (x: α), v.index α i = .ret x := by - progress as ⟨ x ⟩ + progress with vec_index_test as ⟨ x ⟩ simp set_option trace.Progress false -end Test --/ +end Test -/ end Progress diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index 9cd0db23..acaeb26a 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -142,6 +142,25 @@ private def test2 (x : Nat) : Nat := x print_decl test1 print_decl test2 +#check LocalDecl + +def printDecls (decls : List LocalDecl) : MetaM Unit := do + let decls ← decls.foldrM (λ decl msg => do + pure (m!"\n{decl.toExpr} : {← inferType decl.toExpr}" ++ msg)) m!"" + logInfo m!"# Ctx decls:{decls}" + +-- Small utility: print all the declarations in the context (including the "implementation details") +elab "print_all_ctx_decls" : tactic => do + let ctx ← Lean.MonadLCtx.getLCtx + let decls ← ctx.getAllDecls + printDecls decls + +-- Small utility: print all declarations in the context +elab "print_ctx_decls" : tactic => do + let ctx ← Lean.MonadLCtx.getLCtx + let decls ← ctx.getDecls + printDecls decls + -- A map visitor function for expressions (adapted from `AbstractNestedProofs.visit`) -- The continuation takes as parameters: -- - the current depth of the expression (useful for printing/debugging) diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index ee22bebd..3b9b960f 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -115,6 +115,37 @@ theorem insert_in_list_spec {α : Type} (key: Usize) (value: α) (ls: List α) : simp [insert_in_list] at hi exact hi +set_option trace.Progress true +@[pspec] +theorem insert_in_list_spec1 {α : Type} (key: Usize) (value: α) (ls: List α) : + ∃ b, + insert_in_list α key value ls = ret b ∧ + (b ↔ List.lookup ls.v key = none) + := match ls with + | .Nil => by simp [insert_in_list, insert_in_list_loop, List.lookup] + | .Cons k v tl => + if h: k = key then -- TODO: The order of k/key matters + by + simp [insert_in_list, List.lookup] + rw [insert_in_list_loop] + simp [h] + else + by + simp only [insert_in_list] + rw [insert_in_list_loop] + conv => rhs; ext; simp [*] + progress as ⟨ b hi ⟩ + + -- TODO: use progress: detect that this is a recursive call, or give + -- the possibility of specifying an identifier + have ⟨ b, hi ⟩ := insert_in_list_spec key value tl + exists b + simp [insert_in_list, List.lookup] + rw [insert_in_list_loop] -- TODO: Using it in simp leads to infinite recursion + simp [h] + simp [insert_in_list] at hi + exact hi + @[pspec] theorem insert_in_list_spec2 {α : Type} (key: Usize) (value: α) (ls: List α) : ∃ b, @@ -130,8 +161,7 @@ theorem insert_in_list_spec2 {α : Type} (key: Usize) (value: α) (ls: List α) if h: k = key then simp [h] else - conv => - rhs; ext; left; simp [h] -- TODO: Simplify + conv => rhs; ext; left; simp [h] -- TODO: Simplify simp only [insert_in_list] at ih; -- TODO: give the possibility of using underscores progress as ⟨ b h ⟩ -- cgit v1.3.1 From 753907aafc2502ced0cd8c3f9bc43fb1c4b30e93 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 19 Jul 2023 14:48:36 +0200 Subject: Cleanup a bit --- backends/lean/Base/Progress/Progress.lean | 2 -- 1 file changed, 2 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 3b0248fe..9e2461a2 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -218,8 +218,6 @@ def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Na syntax progressArgs := ("with" ident)? ("as" " ⟨ " (ident)+ " ⟩")? -#check Environment -#check ConstMap def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do let args := args.raw -- Process the arguments to retrieve the identifiers to use -- cgit v1.3.1 From 36258c9ba583f19b5ddcb3b90e6521f9845b8944 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 19 Jul 2023 16:41:22 +0200 Subject: Start implementing support for some type classes for progress --- backends/lean/Base/Progress/Base.lean | 64 ++++++++++++++++++++++++- backends/lean/Base/Progress/Progress.lean | 78 ++++++++++++++++++++++--------- 2 files changed, 117 insertions(+), 25 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index 7eace667..0032c33d 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -121,19 +121,42 @@ section Methods end Methods - def getPSpecFunName (th : Expr) : MetaM Name := withPSpec th (fun d => do pure d.fName) true +def getPSpecClassFunNames (th : Expr) : MetaM (Name × Name) := + withPSpec th (fun d => do + let arg0 := d.args.get! 0 + arg0.withApp fun f _ => do + if ¬ f.isConst then throwError "Not a constant: {f}" + pure (d.fName, f.constName) + ) true + +-- "Regular" pspec attribute structure PSpecAttr where attr : AttributeImpl ext : MapDeclarationExtension Name deriving Inhabited +/- pspec attribute for type classes: we use the name of the type class to + lookup another map. We use the *first* argument of the type class to lookup + into this second map. + + Example: + ======== + We use type classes for addition. For instance, the addition between two + U32 is written (without syntactic sugar) as `HAdd.add (Scalar ) x y`. As a consequence, + we store the theorem through the bindings: HAdd.add → Scalar → ... +-/ +structure PSpecClassAttr where + attr : AttributeImpl + ext : MapDeclarationExtension (NameMap Name) + deriving Inhabited + /- The persistent map from function to pspec theorems. -/ initialize pspecAttr : PSpecAttr ← do let ext ← mkMapDeclarationExtension `pspecMap - let attrImpl := { + let attrImpl : AttributeImpl := { name := `pspec descr := "Marks theorems to use with the `progress` tactic" add := fun thName stx attrKind => do @@ -153,7 +176,44 @@ initialize pspecAttr : PSpecAttr ← do registerBuiltinAttribute attrImpl pure { attr := attrImpl, ext := ext } +/- The persistent map from type classes to pspec theorems -/ +initialize pspecClassAttr : PSpecClassAttr ← do + let ext : MapDeclarationExtension (NameMap Name) ← mkMapDeclarationExtension `pspecClassMap + let attrImpl : AttributeImpl := { + name := `cpspec + descr := "Marks theorems to use for type classes with the `progress` tactic" + add := fun thName stx attrKind => do + Attribute.Builtin.ensureNoArgs stx + -- TODO: use the attribute kind + unless attrKind == AttributeKind.global do + throwError "invalid attribute 'cpspec', must be global" + -- Lookup the theorem + let env ← getEnv + let thDecl := env.constants.find! thName + let (fName, argName) ← MetaM.run' (getPSpecClassFunNames thDecl.type) + trace[Progress] "Registering class spec theorem for ({fName}, {argName})" + -- Update the entry if there is one, add an entry if there is none + let env := + match (ext.getState (← getEnv)).find? fName with + | none => + let m := RBMap.ofList [(argName, thName)] + ext.addEntry env (fName, m) + | some m => + let m := m.insert argName thName + ext.addEntry env (fName, m) + setEnv env + pure () + } + registerBuiltinAttribute attrImpl + pure { attr := attrImpl, ext := ext } + + def PSpecAttr.find? (s : PSpecAttr) (name : Name) : MetaM (Option Name) := do return (s.ext.getState (← getEnv)).find? name +def PSpecClassAttr.find? (s : PSpecClassAttr) (className argName : Name) : MetaM (Option Name) := do + match (s.ext.getState (← getEnv)).find? className with + | none => return none + | some map => return map.find? argName + end Progress diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 9e2461a2..64d1c14a 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -152,6 +152,15 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) -- pure .Ok +-- Small utility: if `args` is not empty, return the name of the app in the first +-- arg, if it is a const. +def getFirstArgAppName (args : Array Expr) : MetaM (Option Name) := do + if args.size = 0 then pure none + else + (args.get! 0).withApp fun f _ => do + if f.isConst then pure (some f.constName) + else pure none + -- The array of ids are identifiers to use when introducing fresh variables def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Name) (asmTac : TacticM Unit) : TacticM Unit := do withMainContext do @@ -187,34 +196,57 @@ def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Na -- It failed: try to lookup a theorem -- TODO: use a list of theorems, and try them one by one? trace[Progress] "No assumption succeeded: trying to lookup a theorem" - let thName ← do - match ← pspecAttr.find? fName with - | none => throwError "Could not find a pspec theorem for {fName}" - | some thName => pure thName - trace[Progress] "Lookuped up theorem: {thName}" - -- Apply the theorem - let res ← do - try - let res ← progressWith fnExpr (.Theorem thName) ids asmTac - pure (some res) - catch _ => none + let res ← + match ← pspecAttr.find? fName with + | some thName => + trace[Progress] "Lookuped up theorem: {thName}" + -- Apply the theorem + let res ← do + try + let res ← progressWith fnExpr (.Theorem thName) ids asmTac + pure (some res) + catch _ => none + | none => + trace[Progress] "Could not find a pspec theorem for {fName}" + throwError "TODO" match res with | some .Ok => return () | some (.Error msg) => throwError msg | none => - -- Try a recursive call - we try the assumptions of kind "auxDecl" - let ctx ← Lean.MonadLCtx.getLCtx - let decls ← ctx.getAllDecls - let decls := decls.filter (λ decl => match decl.kind with - | .default | .implDetail => false | .auxDecl => true) - for decl in decls.reverse do - trace[Progress] "Trying recursive assumption: {decl.userName} : {decl.type}" - let res ← do try progressWith fnExpr (.Local decl) ids asmTac catch _ => continue + -- It failed: try to lookup a *class* spec theorem + let res ← do + match ← getFirstArgAppName args with + | none => none + | some argName => do + match ← pspecClassAttr.find? fName argName with + | some thName => + trace[Progress] "Lookuped up class theorem: {thName}" + -- Apply the theorem + let res ← do + try + let res ← progressWith fnExpr (.Theorem thName) ids asmTac + pure (some res) + catch _ => none + | none => + trace[Progress] "Could not find a pspec theorem for {fName}" + pure none match res with - | .Ok => return () - | .Error msg => throwError msg - -- Nothing worked: failed - throwError "Progress failed" + | some .Ok => return () + | some (.Error msg) => throwError msg + | none => + -- Try a recursive call - we try the assumptions of kind "auxDecl" + let ctx ← Lean.MonadLCtx.getLCtx + let decls ← ctx.getAllDecls + let decls := decls.filter (λ decl => match decl.kind with + | .default | .implDetail => false | .auxDecl => true) + for decl in decls.reverse do + trace[Progress] "Trying recursive assumption: {decl.userName} : {decl.type}" + let res ← do try progressWith fnExpr (.Local decl) ids asmTac catch _ => continue + match res with + | .Ok => return () + | .Error msg => throwError msg + -- Nothing worked: failed + throwError "Progress failed" syntax progressArgs := ("with" ident)? ("as" " ⟨ " (ident)+ " ⟩")? -- cgit v1.3.1 From abee28555eb9f95b1c548cc17b9fe746bc982b56 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 19 Jul 2023 18:50:19 +0200 Subject: Add some utilities for progress --- backends/lean/Base/Progress/Base.lean | 19 +++++++++++++++++++ backends/lean/Base/Progress/Progress.lean | 21 ++++++++++++++++----- 2 files changed, 35 insertions(+), 5 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index 0032c33d..785b9362 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -211,9 +211,28 @@ initialize pspecClassAttr : PSpecClassAttr ← do def PSpecAttr.find? (s : PSpecAttr) (name : Name) : MetaM (Option Name) := do return (s.ext.getState (← getEnv)).find? name +def PSpecAttr.getState (s : PSpecAttr) : MetaM (NameMap Name) := do + pure (s.ext.getState (← getEnv)) + def PSpecClassAttr.find? (s : PSpecClassAttr) (className argName : Name) : MetaM (Option Name) := do match (s.ext.getState (← getEnv)).find? className with | none => return none | some map => return map.find? argName +def PSpecClassAttr.getState (s : PSpecClassAttr) : MetaM (NameMap (NameMap Name)) := do + pure (s.ext.getState (← getEnv)) + +def showStoredPSpec : MetaM Unit := do + let st ← pspecAttr.getState + let s := st.toList.foldl (fun s (f, th) => f!"{s}\n{f} → {th}") f!"" + IO.println s + +def showStoredPSpecClass : MetaM Unit := do + let st ← pspecClassAttr.getState + let s := st.toList.foldl (fun s (f, m) => + let ms := m.toList.foldl (fun s (f, th) => + f!"{s}\n {f} → {th}") f!"" + f!"{s}\n{f} → [{ms}]") f!"" + IO.println s + end Progress diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 64d1c14a..9c75ee3c 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -208,7 +208,7 @@ def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Na catch _ => none | none => trace[Progress] "Could not find a pspec theorem for {fName}" - throwError "TODO" + pure none match res with | some .Ok => return () | some (.Error msg) => throwError msg @@ -228,7 +228,7 @@ def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Na pure (some res) catch _ => none | none => - trace[Progress] "Could not find a pspec theorem for {fName}" + trace[Progress] "Could not find a class pspec theorem for ({fName}, {argName})" pure none match res with | some .Ok => return () @@ -287,11 +287,22 @@ elab "progress" args:progressArgs : tactic => /- -- TODO: remove namespace Test - open Primitives + open Primitives Result set_option trace.Progress true - set_option pp.rawOnError true + -- #eval do pspecClassAttr.getState + -- #eval showStoredPSpec + -- #eval showStoredPSpecClass + +/- theorem Scalar.add_spec {ty} {x y : Scalar ty} + (hmin : Scalar.min ty ≤ x.val + y.val) + (hmax : x.val + y.val ≤ Scalar.max ty) : + ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by + progress + simp [*] -/ + +/- @[pspec] theorem vec_index_test2 (α : Type u) (v: Vec α) (i: Usize) (h: i.val < v.val.length) : ∃ (x: α), v.index α i = .ret x := by @@ -299,7 +310,7 @@ namespace Test simp set_option trace.Progress false - +-/ end Test -/ end Progress -- cgit v1.3.1 From 821b09b14794ebc2fe7b7047fc60fd56fb2cd107 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 19 Jul 2023 19:03:17 +0200 Subject: Fix a small issue with the persistent state of progress --- backends/lean/Base/Progress/Base.lean | 9 +++++++++ backends/lean/Base/Progress/Progress.lean | 9 ++++----- 2 files changed, 13 insertions(+), 5 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index 785b9362..72438d40 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -153,6 +153,15 @@ structure PSpecClassAttr where ext : MapDeclarationExtension (NameMap Name) 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 α) := + registerSimplePersistentEnvExtension { + name := name, + addImportedFn := fun a => a.foldl (fun s a => a.foldl (fun s (k, v) => s.insert k v) 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 diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 9c75ee3c..84053150 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -291,16 +291,15 @@ namespace Test set_option trace.Progress true - -- #eval do pspecClassAttr.getState - -- #eval showStoredPSpec - -- #eval showStoredPSpecClass + #eval showStoredPSpec + #eval showStoredPSpecClass -/- theorem Scalar.add_spec {ty} {x y : Scalar ty} + theorem Scalar.add_spec {ty} {x y : Scalar ty} (hmin : Scalar.min ty ≤ x.val + y.val) (hmax : x.val + y.val ≤ Scalar.max ty) : ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by progress - simp [*] -/ + simp [*] /- @[pspec] -- cgit v1.3.1 From 975b7c555cbffef2648a6469b777d1f1760d926d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 20 Jul 2023 11:22:18 +0200 Subject: Improve progress further --- backends/lean/Base/Progress/Base.lean | 102 +++++++++++++++++++++------ backends/lean/Base/Progress/Progress.lean | 112 +++++++++++++++++------------- 2 files changed, 142 insertions(+), 72 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index 72438d40..3599d866 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -62,24 +62,6 @@ section Methods -- Dive into the quantified variables and the assumptions forallTelescope th fun fvars th => do trace[Progress] "Universally quantified arguments and assumptions: {fvars}" - /- -- Filter the argumens which are not propositions - let rec getFirstPropIdx (i : Nat) : MetaM Nat := do - if i ≥ fargs.size then pure i - else do - let x := fargs.get! i - if ← Meta.isProp (← inferType x) then pure i - else getFirstPropIdx (i + 1) - let i ← getFirstPropIdx 0 - let fvars := fargs.extract 0 i - let hyps := fargs.extract i fargs.size - trace[Progress] "Quantified variables: {fvars}" - trace[Progress] "Assumptions: {hyps}" - -- Sanity check: all hypotheses are propositions (in particular, all the - -- quantified variables are at the beginning) - let hypsAreProp ← hyps.allM fun x => do Meta.isProp (← inferType x) - if ¬ hypsAreProp then - throwError "The theorem doesn't have the proper shape: all the quantified arguments should be at the beginning" - -/ -- Dive into the existentials existsTelescope th fun evars th => do trace[Progress] "Existentials: {evars}" @@ -98,6 +80,8 @@ section Methods let allArgsFVars ← args.foldlM (fun hs arg => getFVarIds arg hs) HashSet.empty -- Sanity check if sanityChecks then + -- All the variables which appear in the inputs given to the function are + -- universally quantified (in particular, they are not *existentially* quantified) let fvarsSet : HashSet FVarId := HashSet.ofArray (fvars.map (fun x => x.fvarId!)) let filtArgsFVars := allArgsFVars.toArray.filter (fun fvar => ¬ fvarsSet.contains fvar) if ¬ filtArgsFVars.isEmpty then @@ -132,6 +116,12 @@ def getPSpecClassFunNames (th : Expr) : MetaM (Name × Name) := pure (d.fName, f.constName) ) true +def getPSpecClassFunNameArg (th : Expr) : MetaM (Name × Expr) := + withPSpec th (fun d => do + let arg0 := d.args.get! 0 + pure (d.fName, arg0) + ) true + -- "Regular" pspec attribute structure PSpecAttr where attr : AttributeImpl @@ -145,14 +135,26 @@ structure PSpecAttr where Example: ======== We use type classes for addition. For instance, the addition between two - U32 is written (without syntactic sugar) as `HAdd.add (Scalar ) x y`. As a consequence, + U32 is written (without syntactic sugar) as `HAdd.add (Scalar ty) x y`. As a consequence, we store the theorem through the bindings: HAdd.add → Scalar → ... + + SH: TODO: this (and `PSpecClassExprAttr`) is a bit ad-hoc. For now it works for the + specs of the scalar operations, which is what I really need, but I'm not sure it + applies well to other situations. A better way would probably to use type classes, but + I couldn't get them to work on those cases. It is worth retrying. -/ structure PSpecClassAttr where attr : AttributeImpl ext : MapDeclarationExtension (NameMap Name) deriving Inhabited +/- Same as `PSpecClassAttr` but we use the full first argument (it works when it + is a constant). -/ +structure PSpecClassExprAttr where + attr : AttributeImpl + ext : MapDeclarationExtension (HashMap Expr Name) + 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 α) := registerSimplePersistentEnvExtension { @@ -216,21 +218,69 @@ initialize pspecClassAttr : PSpecClassAttr ← do registerBuiltinAttribute attrImpl pure { attr := attrImpl, ext := ext } +/- The 2nd persistent map from type classes to pspec theorems -/ +initialize pspecClassExprAttr : PSpecClassExprAttr ← do + let ext : MapDeclarationExtension (HashMap Expr Name) ← mkMapDeclarationExtension `pspecClassExprMap + let attrImpl : AttributeImpl := { + name := `cepspec + descr := "Marks theorems to use for type classes with the `progress` tactic" + add := fun thName stx attrKind => do + Attribute.Builtin.ensureNoArgs stx + -- TODO: use the attribute kind + unless attrKind == AttributeKind.global do + throwError "invalid attribute 'cpspec', must be global" + -- Lookup the theorem + let env ← getEnv + let thDecl := env.constants.find! thName + let (fName, arg) ← MetaM.run' (getPSpecClassFunNameArg thDecl.type) + -- Sanity check: no variables appear in the argument + MetaM.run' do + let fvars ← getFVarIds arg + if ¬ fvars.isEmpty then throwError "The first argument ({arg}) contains variables" + -- We store two bindings: + -- - arg to theorem name + -- - reduced arg to theorem name + let rarg ← MetaM.run' (reduce arg) + trace[Progress] "Registering class spec theorem for ({fName}, {arg}) and ({fName}, {rarg})" + -- Update the entry if there is one, add an entry if there is none + let env := + match (ext.getState (← getEnv)).find? fName with + | none => + let m := HashMap.ofList [(arg, thName), (rarg, thName)] + ext.addEntry env (fName, m) + | some m => + let m := m.insert arg thName + let m := m.insert rarg thName + ext.addEntry env (fName, m) + setEnv env + pure () + } + registerBuiltinAttribute attrImpl + pure { attr := attrImpl, ext := ext } + def PSpecAttr.find? (s : PSpecAttr) (name : Name) : MetaM (Option Name) := do return (s.ext.getState (← getEnv)).find? name -def PSpecAttr.getState (s : PSpecAttr) : MetaM (NameMap Name) := do - pure (s.ext.getState (← getEnv)) - def PSpecClassAttr.find? (s : PSpecClassAttr) (className argName : Name) : MetaM (Option Name) := do match (s.ext.getState (← getEnv)).find? className with | none => return none | some map => return map.find? argName +def PSpecClassExprAttr.find? (s : PSpecClassExprAttr) (className : Name) (arg : Expr) : MetaM (Option Name) := do + match (s.ext.getState (← getEnv)).find? className with + | none => return none + | some map => return map.find? arg + +def PSpecAttr.getState (s : PSpecAttr) : MetaM (NameMap Name) := do + pure (s.ext.getState (← getEnv)) + def PSpecClassAttr.getState (s : PSpecClassAttr) : MetaM (NameMap (NameMap Name)) := do pure (s.ext.getState (← getEnv)) +def PSpecClassExprAttr.getState (s : PSpecClassExprAttr) : MetaM (NameMap (HashMap Expr Name)) := do + pure (s.ext.getState (← getEnv)) + def showStoredPSpec : MetaM Unit := do let st ← pspecAttr.getState let s := st.toList.foldl (fun s (f, th) => f!"{s}\n{f} → {th}") f!"" @@ -244,4 +294,12 @@ def showStoredPSpecClass : MetaM Unit := do f!"{s}\n{f} → [{ms}]") f!"" IO.println s +def showStoredPSpecExprClass : MetaM Unit := do + let st ← pspecClassExprAttr.getState + let s := st.toList.foldl (fun s (f, m) => + let ms := m.toList.foldl (fun s (f, th) => + f!"{s}\n {f} → {th}") f!"" + f!"{s}\n{f} → [{ms}]") f!"" + IO.println s + end Progress diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 84053150..974a6364 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -27,6 +27,9 @@ inductive TheoremOrLocal where | Theorem (thName : Name) | Local (asm : LocalDecl) +instance : ToMessageData TheoremOrLocal where + toMessageData := λ x => match x with | .Theorem thName => m!"{thName}" | .Local asm => m!"{asm.userName}" + /- Type to propagate the errors of `progressWith`. We need this because we use the exceptions to backtrack, when trying to use the assumptions for instance. When there is actually an error we want @@ -161,6 +164,32 @@ def getFirstArgAppName (args : Array Expr) : MetaM (Option Name) := do if f.isConst then pure (some f.constName) else pure none +def getFirstArg (args : Array Expr) : Option Expr := do + if args.size = 0 then none + else some (args.get! 0) + +/- Helper: try to lookup a theorem and apply it, or continue with another tactic + if it fails -/ +def tryLookupApply (ids : Array Name) (asmTac : TacticM Unit) (fnExpr : Expr) + (kind : String) (th : Option TheoremOrLocal) (x : TacticM Unit) : TacticM Unit := do + let res ← do + match th with + | none => + trace[Progress] "Could not find a {kind}" + pure none + | some th => do + trace[Progress] "Lookuped up {kind}: {th}" + -- Apply the theorem + let res ← do + try + let res ← progressWith fnExpr th ids asmTac + pure (some res) + catch _ => none + match res with + | some .Ok => return () + | some (.Error msg) => throwError msg + | none => x + -- The array of ids are identifiers to use when introducing fresh variables def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Name) (asmTac : TacticM Unit) : TacticM Unit := do withMainContext do @@ -196,57 +225,40 @@ def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Na -- It failed: try to lookup a theorem -- TODO: use a list of theorems, and try them one by one? trace[Progress] "No assumption succeeded: trying to lookup a theorem" - let res ← - match ← pspecAttr.find? fName with - | some thName => - trace[Progress] "Lookuped up theorem: {thName}" - -- Apply the theorem - let res ← do - try - let res ← progressWith fnExpr (.Theorem thName) ids asmTac - pure (some res) - catch _ => none - | none => - trace[Progress] "Could not find a pspec theorem for {fName}" - pure none - match res with - | some .Ok => return () - | some (.Error msg) => throwError msg - | none => - -- It failed: try to lookup a *class* spec theorem - let res ← do - match ← getFirstArgAppName args with - | none => none - | some argName => do - match ← pspecClassAttr.find? fName argName with - | some thName => - trace[Progress] "Lookuped up class theorem: {thName}" - -- Apply the theorem - let res ← do - try - let res ← progressWith fnExpr (.Theorem thName) ids asmTac - pure (some res) - catch _ => none - | none => - trace[Progress] "Could not find a class pspec theorem for ({fName}, {argName})" - pure none + let pspec ← do + let thName ← pspecAttr.find? fName + pure (thName.map fun th => .Theorem th) + tryLookupApply ids asmTac fnExpr "pspec theorem" pspec do + -- It failed: try to lookup a *class* expr spec theorem (those are more + -- specific than class spec theorems) + let pspecClassExpr ← do + match getFirstArg args with + | none => pure none + | some arg => do + let thName ← pspecClassExprAttr.find? fName arg + pure (thName.map fun th => .Theorem th) + tryLookupApply ids asmTac fnExpr "pspec class expr theorem" pspecClassExpr do + -- It failed: try to lookup a *class* spec theorem + let pspecClass ← do + match ← getFirstArgAppName args with + | none => pure none + | some argName => do + let thName ← pspecClassAttr.find? fName argName + pure (thName.map fun th => .Theorem th) + tryLookupApply ids asmTac fnExpr "pspec class theorem" pspecClass do + -- Try a recursive call - we try the assumptions of kind "auxDecl" + let ctx ← Lean.MonadLCtx.getLCtx + let decls ← ctx.getAllDecls + let decls := decls.filter (λ decl => match decl.kind with + | .default | .implDetail => false | .auxDecl => true) + for decl in decls.reverse do + trace[Progress] "Trying recursive assumption: {decl.userName} : {decl.type}" + let res ← do try progressWith fnExpr (.Local decl) ids asmTac catch _ => continue match res with - | some .Ok => return () - | some (.Error msg) => throwError msg - | none => - -- Try a recursive call - we try the assumptions of kind "auxDecl" - let ctx ← Lean.MonadLCtx.getLCtx - let decls ← ctx.getAllDecls - let decls := decls.filter (λ decl => match decl.kind with - | .default | .implDetail => false | .auxDecl => true) - for decl in decls.reverse do - trace[Progress] "Trying recursive assumption: {decl.userName} : {decl.type}" - let res ← do try progressWith fnExpr (.Local decl) ids asmTac catch _ => continue - match res with - | .Ok => return () - | .Error msg => throwError msg - -- Nothing worked: failed - throwError "Progress failed" + | .Ok => return () + | .Error msg => throwError msg + -- Nothing worked: failed + throwError "Progress failed" syntax progressArgs := ("with" ident)? ("as" " ⟨ " (ident)+ " ⟩")? -- cgit v1.3.1 From d87e35e1a53b2252cc2c8c554216115773fd9678 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 20 Jul 2023 11:38:55 +0200 Subject: Add fine-grained lemmas for the arithmetic operations --- backends/lean/Base/Primitives/Scalar.lean | 137 ++++++++++++++++++++++++++++-- backends/lean/Base/Progress/Base.lean | 2 +- 2 files changed, 131 insertions(+), 8 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Primitives/Scalar.lean b/backends/lean/Base/Primitives/Scalar.lean index aaa4027f..1e9b51c2 100644 --- a/backends/lean/Base/Primitives/Scalar.lean +++ b/backends/lean/Base/Primitives/Scalar.lean @@ -438,7 +438,7 @@ instance {ty} : HDiv (Scalar ty) (Scalar ty) (Result (Scalar ty)) where instance {ty} : HMod (Scalar ty) (Scalar ty) (Result (Scalar ty)) where hMod x y := Scalar.rem x y --- TODO: make progress work at a more fine grained level (see `Scalar.add_unsigned_spec`) +-- Generic theorem - shouldn't be used much @[cpspec] theorem Scalar.add_spec {ty} {x y : Scalar ty} (hmin : Scalar.min ty ≤ x.val + y.val) @@ -460,7 +460,32 @@ theorem Scalar.add_unsigned_spec {ty} (s: ¬ ty.isSigned) {x y : Scalar ty} cases ty <;> simp [min] at * <;> linarith apply add_spec <;> assumption --- TODO: make it finer grained +/- Fine-grained theorems -/ +@[cepspec] theorem Usize.add_spec {x y : Usize} (hmax : x.val + y.val ≤ Usize.max) : + ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by + apply Scalar.add_unsigned_spec <;> simp only [Scalar.max, *] + +@[cepspec] theorem U8.add_spec {x y : U8} (hmax : x.val + y.val ≤ U8.max) : + ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by + apply Scalar.add_unsigned_spec <;> simp only [Scalar.max, *] + +@[cepspec] theorem U16.add_spec {x y : U16} (hmax : x.val + y.val ≤ U16.max) : + ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by + apply Scalar.add_unsigned_spec <;> simp only [Scalar.max, *] + +@[cepspec] theorem U32.add_spec {x y : U32} (hmax : x.val + y.val ≤ U32.max) : + ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by + apply Scalar.add_unsigned_spec <;> simp only [Scalar.max, *] + +@[cepspec] theorem U64.add_spec {x y : U64} (hmax : x.val + y.val ≤ U64.max) : + ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by + apply Scalar.add_unsigned_spec <;> simp only [Scalar.max, *] + +@[cepspec] theorem U128.add_spec {x y : U128} (hmax : x.val + y.val ≤ U128.max) : + ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by + apply Scalar.add_unsigned_spec <;> simp only [Scalar.max, *] + +-- Generic theorem - shouldn't be used much @[cpspec] theorem Scalar.sub_spec {ty} {x y : Scalar ty} (hmin : Scalar.min ty ≤ x.val - y.val) @@ -484,8 +509,32 @@ theorem Scalar.sub_unsigned_spec {ty} (s: ¬ ty.isSigned) {x y : Scalar ty} intros apply sub_spec <;> assumption --- TODO: make it finer grained -@[cpspec] +/- Fine-grained theorems -/ +@[cepspec] theorem Usize.sub_spec {x y : Usize} (hmin : Usize.min ≤ x.val - y.val) : + ∃ z, x - y = ret z ∧ z.val = x.val - y.val := by + apply Scalar.sub_unsigned_spec <;> simp only [Scalar.min, *] + +@[cepspec] theorem U8.sub_spec {x y : U8} (hmin : U8.min ≤ x.val - y.val) : + ∃ z, x - y = ret z ∧ z.val = x.val - y.val := by + apply Scalar.sub_unsigned_spec <;> simp only [Scalar.min, *] + +@[cepspec] theorem U16.sub_spec {x y : U16} (hmin : U16.min ≤ x.val - y.val) : + ∃ z, x - y = ret z ∧ z.val = x.val - y.val := by + apply Scalar.sub_unsigned_spec <;> simp only [Scalar.min, *] + +@[cepspec] theorem U32.sub_spec {x y : U32} (hmin : U32.min ≤ x.val - y.val) : + ∃ z, x - y = ret z ∧ z.val = x.val - y.val := by + apply Scalar.sub_unsigned_spec <;> simp only [Scalar.min, *] + +@[cepspec] theorem U64.sub_spec {x y : U64} (hmin : U64.min ≤ x.val - y.val) : + ∃ z, x - y = ret z ∧ z.val = x.val - y.val := by + apply Scalar.sub_unsigned_spec <;> simp only [Scalar.min, *] + +@[cepspec] theorem U128.sub_spec {x y : U128} (hmin : U128.min ≤ x.val - y.val) : + ∃ z, x - y = ret z ∧ z.val = x.val - y.val := by + apply Scalar.sub_unsigned_spec <;> simp only [Scalar.min, *] + +-- Generic theorem - shouldn't be used much theorem Scalar.mul_spec {ty} {x y : Scalar ty} (hmin : Scalar.min ty ≤ x.val * y.val) (hmax : x.val * y.val ≤ Scalar.max ty) : @@ -506,7 +555,32 @@ theorem Scalar.mul_unsigned_spec {ty} (s: ¬ ty.isSigned) {x y : Scalar ty} cases ty <;> simp at * <;> apply mul_nonneg hx hy apply mul_spec <;> assumption --- TODO: make it finer grained +/- Fine-grained theorems -/ +@[cepspec] theorem Usize.mul_spec {x y : Usize} (hmax : x.val * y.val ≤ Usize.max) : + ∃ z, x * y = ret z ∧ z.val = x.val * y.val := by + apply Scalar.mul_unsigned_spec <;> simp only [Scalar.max, *] + +@[cepspec] theorem U8.mul_spec {x y : U8} (hmax : x.val * y.val ≤ U8.max) : + ∃ z, x * y = ret z ∧ z.val = x.val * y.val := by + apply Scalar.mul_unsigned_spec <;> simp only [Scalar.max, *] + +@[cepspec] theorem U16.mul_spec {x y : U16} (hmax : x.val * y.val ≤ U16.max) : + ∃ z, x * y = ret z ∧ z.val = x.val * y.val := by + apply Scalar.mul_unsigned_spec <;> simp only [Scalar.max, *] + +@[cepspec] theorem U32.mul_spec {x y : U32} (hmax : x.val * y.val ≤ U32.max) : + ∃ z, x * y = ret z ∧ z.val = x.val * y.val := by + apply Scalar.mul_unsigned_spec <;> simp only [Scalar.max, *] + +@[cepspec] theorem U64.mul_spec {x y : U64} (hmax : x.val * y.val ≤ U64.max) : + ∃ z, x * y = ret z ∧ z.val = x.val * y.val := by + apply Scalar.mul_unsigned_spec <;> simp only [Scalar.max, *] + +@[cepspec] theorem U128.mul_spec {x y : U128} (hmax : x.val * y.val ≤ U128.max) : + ∃ z, x * y = ret z ∧ z.val = x.val * y.val := by + apply Scalar.mul_unsigned_spec <;> simp only [Scalar.max, *] + +-- Generic theorem - shouldn't be used much @[cpspec] theorem Scalar.div_spec {ty} {x y : Scalar ty} (hnz : y.val ≠ 0) @@ -534,7 +608,32 @@ theorem Scalar.div_unsigned_spec {ty} (s: ¬ ty.isSigned) (x : Scalar ty) {y : S simp [*] at hs apply hs --- TODO: make it finer grained +/- Fine-grained theorems -/ +@[cepspec] theorem Usize.div_spec (x : Usize) {y : Usize} (hnz : y.val ≠ 0) : + ∃ z, x / y = ret z ∧ z.val = x.val / y.val := by + apply Scalar.div_unsigned_spec <;> simp [*] + +@[cepspec] theorem U8.div_spec (x : U8) {y : U8} (hnz : y.val ≠ 0) : + ∃ z, x / y = ret z ∧ z.val = x.val / y.val := by + apply Scalar.div_unsigned_spec <;> simp [Scalar.max, *] + +@[cepspec] theorem U16.div_spec (x : U16) {y : U16} (hnz : y.val ≠ 0) : + ∃ z, x / y = ret z ∧ z.val = x.val / y.val := by + apply Scalar.div_unsigned_spec <;> simp [Scalar.max, *] + +@[cepspec] theorem U32.div_spec (x : U32) {y : U32} (hnz : y.val ≠ 0) : + ∃ z, x / y = ret z ∧ z.val = x.val / y.val := by + apply Scalar.div_unsigned_spec <;> simp [Scalar.max, *] + +@[cepspec] theorem U64.div_spec (x : U64) {y : U64} (hnz : y.val ≠ 0) : + ∃ z, x / y = ret z ∧ z.val = x.val / y.val := by + apply Scalar.div_unsigned_spec <;> simp [Scalar.max, *] + +@[cepspec] theorem U128.div_spec (x : U128) {y : U128} (hnz : y.val ≠ 0) : + ∃ z, x / y = ret z ∧ z.val = x.val / y.val := by + apply Scalar.div_unsigned_spec <;> simp [Scalar.max, *] + +-- Generic theorem - shouldn't be used much @[cpspec] theorem Scalar.rem_spec {ty} {x y : Scalar ty} (hnz : y.val ≠ 0) @@ -548,7 +647,7 @@ theorem Scalar.rem_spec {ty} {x y : Scalar ty} theorem Scalar.rem_unsigned_spec {ty} (s: ¬ ty.isSigned) (x : Scalar ty) {y : Scalar ty} (hnz : y.val ≠ 0) : - ∃ z, x % y = ret z ∧ z.val = scalar_rem x.val y.val := by + ∃ z, x % y = ret z ∧ z.val = x.val % y.val := by have h : Scalar.min ty = 0 := by cases ty <;> simp at * have hx := x.hmin have hy := y.hmin @@ -565,6 +664,30 @@ theorem Scalar.rem_unsigned_spec {ty} (s: ¬ ty.isSigned) (x : Scalar ty) {y : S simp [*] at hs simp [*] +@[cepspec] theorem Usize.rem_spec (x : Usize) {y : Usize} (hnz : y.val ≠ 0) : + ∃ z, x % y = ret z ∧ z.val = x.val % y.val := by + apply Scalar.rem_unsigned_spec <;> simp [*] + +@[cepspec] theorem U8.rem_spec (x : U8) {y : U8} (hnz : y.val ≠ 0) : + ∃ z, x % y = ret z ∧ z.val = x.val % y.val := by + apply Scalar.rem_unsigned_spec <;> simp [Scalar.max, *] + +@[cepspec] theorem U16.rem_spec (x : U16) {y : U16} (hnz : y.val ≠ 0) : + ∃ z, x % y = ret z ∧ z.val = x.val % y.val := by + apply Scalar.rem_unsigned_spec <;> simp [Scalar.max, *] + +@[cepspec] theorem U32.rem_spec (x : U32) {y : U32} (hnz : y.val ≠ 0) : + ∃ z, x % y = ret z ∧ z.val = x.val % y.val := by + apply Scalar.rem_unsigned_spec <;> simp [Scalar.max, *] + +@[cepspec] theorem U64.rem_spec (x : U64) {y : U64} (hnz : y.val ≠ 0) : + ∃ z, x % y = ret z ∧ z.val = x.val % y.val := by + apply Scalar.rem_unsigned_spec <;> simp [Scalar.max, *] + +@[cepspec] theorem U128.rem_spec (x : U128) {y : U128} (hnz : y.val ≠ 0) : + ∃ z, x % y = ret z ∧ z.val = x.val % y.val := by + apply Scalar.rem_unsigned_spec <;> simp [Scalar.max, *] + -- ofIntCore -- TODO: typeclass? def Isize.ofIntCore := @Scalar.ofIntCore .Isize diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index 3599d866..2fbd24dd 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -240,7 +240,7 @@ initialize pspecClassExprAttr : PSpecClassExprAttr ← do -- We store two bindings: -- - arg to theorem name -- - reduced arg to theorem name - let rarg ← MetaM.run' (reduce arg) + let rarg ← MetaM.run' (reduceAll arg) trace[Progress] "Registering class spec theorem for ({fName}, {arg}) and ({fName}, {rarg})" -- Update the entry if there is one, add an entry if there is none let env := -- cgit v1.3.1 From 6ef1d360b89fd9f9383e63609888bf925a6a16ab Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 20 Jul 2023 12:08:09 +0200 Subject: Improve progress further and move some lemmas --- backends/lean/Base/IList/IList.lean | 67 ++++++++++++++++++++++ backends/lean/Base/Progress/Progress.lean | 55 +++++++++++------- tests/lean/Hashmap/Properties.lean | 92 +++---------------------------- 3 files changed, 109 insertions(+), 105 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/IList/IList.lean b/backends/lean/Base/IList/IList.lean index ddb10236..1773e593 100644 --- a/backends/lean/Base/IList/IList.lean +++ b/backends/lean/Base/IList/IList.lean @@ -175,6 +175,73 @@ theorem idrop_eq_nil_of_le (hineq : ls.len ≤ i) : idrop i ls = [] := by apply hi linarith +@[simp] +theorem index_ne + {α : Type u} [Inhabited α] (l: List α) (i: ℤ) (j: ℤ) (x: α) : + 0 ≤ i → i < l.len → 0 ≤ j → j < l.len → j ≠ i → + (l.update i x).index j = l.index j + := + λ _ _ _ _ _ => match l with + | [] => by simp at * + | hd :: tl => + if h: i = 0 then + have : j ≠ 0 := by scalar_tac + by simp [*] + else if h : j = 0 then + have : i ≠ 0 := by scalar_tac + by simp [*] + else + by + simp [*] + simp at * + apply index_ne <;> scalar_tac + +@[simp] +theorem index_eq + {α : Type u} [Inhabited α] (l: List α) (i: ℤ) (x: α) : + 0 ≤ i → i < l.len → + (l.update i x).index i = x + := + fun _ _ => match l with + | [] => by simp at *; exfalso; scalar_tac -- TODO: exfalso needed. Son FIXME + | hd :: tl => + if h: i = 0 then + by + simp [*] + else + by + simp [*] + simp at * + apply index_eq <;> scalar_tac + +def allP {α : Type u} (l : List α) (p: α → Prop) : Prop := + foldr (fun a r => p a ∧ r) True l + +@[simp] +theorem allP_nil {α : Type u} (p: α → Prop) : allP [] p := + by simp [allP, foldr] + +@[simp] +theorem allP_cons {α : Type u} (hd: α) (tl : List α) (p: α → Prop) : + allP (hd :: tl) p ↔ p hd ∧ allP tl p + := by simp [allP, foldr] + +def pairwise_rel + {α : Type u} (rel : α → α → Prop) (l: List α) : Prop + := match l with + | [] => True + | hd :: tl => allP tl (rel hd) ∧ pairwise_rel rel tl + +@[simp] +theorem pairwise_rel_nil {α : Type u} (rel : α → α → Prop) : + pairwise_rel rel [] + := by simp [pairwise_rel] + +@[simp] +theorem pairwise_rel_cons {α : Type u} (rel : α → α → Prop) (hd: α) (tl: List α) : + pairwise_rel rel (hd :: tl) ↔ allP tl (rel hd) ∧ pairwise_rel rel tl + := by simp [pairwise_rel] + end Lemmas end List diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 974a6364..1f734415 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -39,7 +39,7 @@ inductive ProgressError | Error (msg : MessageData) deriving Inhabited -def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) +def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (keep : Option Name) (ids : Array Name) (asmTac : TacticM Unit) : TacticM ProgressError := do /- Apply the theorem We try to match the theorem with the goal @@ -88,7 +88,7 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) match th with | .Theorem thName => mkAppOptM thName (mvars.map some) | .Local decl => mkAppOptM' (mkFVar decl.fvarId) (mvars.map some) - let asmName ← mkFreshUserName `h + let asmName ← do match keep with | none => mkFreshUserName `h | some n => do pure n let thTy ← inferType th let thAsm ← Utils.addDeclTac asmName th thTy (asLet := false) withMainContext do -- The context changed - TODO: remove once addDeclTac is updated @@ -109,7 +109,9 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) if ← isConj (← inferType h) then do let hName := (← h.fvarId!.getDecl).userName let (optId, ids) := listTryPopHead ids - let optIds := match optId with | none => none | some id => some (hName, id) + let optIds ← match optId with + | none => do pure (some (hName, ← mkFreshUserName `h)) + | some id => do pure (some (hName, id)) splitConjTac h optIds (fun hEq hPost => k hEq (some hPost) ids) else k h none ids -- Simplify the target by using the equality and some monad simplifications, @@ -118,9 +120,12 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (ids : Array Name) 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) - -- Clear the equality - let mgoal ← getMainGoal - let mgoal ← mgoal.tryClearMany #[hEq.fvarId!] + -- Clear the equality, unless the user requests not to do so + let mgoal ← do + if keep.isSome then getMainGoal + else do + let mgoal ← getMainGoal + mgoal.tryClearMany #[hEq.fvarId!] setGoals (mgoal :: (← getUnsolvedGoals)) trace[Progress] "Goal after splitting eq and post and simplifying the target: {mgoal}" -- Continue splitting following the ids provided by the user @@ -170,7 +175,7 @@ def getFirstArg (args : Array Expr) : Option Expr := do /- Helper: try to lookup a theorem and apply it, or continue with another tactic if it fails -/ -def tryLookupApply (ids : Array Name) (asmTac : TacticM Unit) (fnExpr : Expr) +def tryLookupApply (keep : Option Name) (ids : Array Name) (asmTac : TacticM Unit) (fnExpr : Expr) (kind : String) (th : Option TheoremOrLocal) (x : TacticM Unit) : TacticM Unit := do let res ← do match th with @@ -182,7 +187,7 @@ def tryLookupApply (ids : Array Name) (asmTac : TacticM Unit) (fnExpr : Expr) -- Apply the theorem let res ← do try - let res ← progressWith fnExpr th ids asmTac + let res ← progressWith fnExpr th keep ids asmTac pure (some res) catch _ => none match res with @@ -191,7 +196,7 @@ def tryLookupApply (ids : Array Name) (asmTac : TacticM Unit) (fnExpr : Expr) | none => x -- The array of ids are identifiers to use when introducing fresh variables -def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Name) (asmTac : TacticM Unit) : TacticM Unit := do +def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrLocal) (ids : Array Name) (asmTac : TacticM Unit) : TacticM Unit := do withMainContext do -- Retrieve the goal let mgoal ← Tactic.getMainGoal @@ -209,7 +214,7 @@ def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Na -- Otherwise, lookup one. match withTh with | some th => do - match ← progressWith fnExpr th ids asmTac with + match ← progressWith fnExpr th keep ids asmTac with | .Ok => return () | .Error msg => throwError msg | none => @@ -218,7 +223,7 @@ def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Na let decls ← ctx.getDecls for decl in decls.reverse do trace[Progress] "Trying assumption: {decl.userName} : {decl.type}" - let res ← do try progressWith fnExpr (.Local decl) ids asmTac catch _ => continue + let res ← do try progressWith fnExpr (.Local decl) keep ids asmTac catch _ => continue match res with | .Ok => return () | .Error msg => throwError msg @@ -228,7 +233,7 @@ def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Na let pspec ← do let thName ← pspecAttr.find? fName pure (thName.map fun th => .Theorem th) - tryLookupApply ids asmTac fnExpr "pspec theorem" pspec do + tryLookupApply keep ids asmTac fnExpr "pspec theorem" pspec do -- It failed: try to lookup a *class* expr spec theorem (those are more -- specific than class spec theorems) let pspecClassExpr ← do @@ -237,7 +242,7 @@ def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Na | some arg => do let thName ← pspecClassExprAttr.find? fName arg pure (thName.map fun th => .Theorem th) - tryLookupApply ids asmTac fnExpr "pspec class expr theorem" pspecClassExpr do + tryLookupApply keep ids asmTac fnExpr "pspec class expr theorem" pspecClassExpr do -- It failed: try to lookup a *class* spec theorem let pspecClass ← do match ← getFirstArgAppName args with @@ -245,7 +250,7 @@ def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Na | some argName => do let thName ← pspecClassAttr.find? fName argName pure (thName.map fun th => .Theorem th) - tryLookupApply ids asmTac fnExpr "pspec class theorem" pspecClass do + tryLookupApply keep ids asmTac fnExpr "pspec class theorem" pspecClass do -- Try a recursive call - we try the assumptions of kind "auxDecl" let ctx ← Lean.MonadLCtx.getLCtx let decls ← ctx.getAllDecls @@ -253,21 +258,29 @@ def progressAsmsOrLookupTheorem (withTh : Option TheoremOrLocal) (ids : Array Na | .default | .implDetail => false | .auxDecl => true) for decl in decls.reverse do trace[Progress] "Trying recursive assumption: {decl.userName} : {decl.type}" - let res ← do try progressWith fnExpr (.Local decl) ids asmTac catch _ => continue + let res ← do try progressWith fnExpr (.Local decl) keep ids asmTac catch _ => continue match res with | .Ok => return () | .Error msg => throwError msg -- Nothing worked: failed throwError "Progress failed" -syntax progressArgs := ("with" ident)? ("as" " ⟨ " (ident)+ " ⟩")? +syntax progressArgs := ("keep" ("as" (ident))?)? ("with" ident)? ("as" " ⟨ " (ident)+ " ⟩")? def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do let args := args.raw -- Process the arguments to retrieve the identifiers to use trace[Progress] "Progress arguments: {args}" let args := args.getArgs - let withArg := (args.get! 0).getArgs + let keep : Option Name ← do + let args := (args.get! 0).getArgs + if args.size > 0 then do + let args := (args.get! 1).getArgs + if args.size > 0 then pure (some (args.get! 1).getId) + else do pure (some (← mkFreshUserName `h)) + else pure none + trace[Progress] "Keep: {keep}" + let withArg := (args.get! 1).getArgs let withArg ← do if withArg.size > 0 then let id := withArg.get! 1 @@ -287,11 +300,11 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do | id :: _ => pure (some (.Theorem id)) else pure none - let args := (args.get! 1).getArgs + let args := (args.get! 2).getArgs let args := (args.get! 2).getArgs let ids := args.map Syntax.getId trace[Progress] "User-provided ids: {ids}" - progressAsmsOrLookupTheorem withArg ids (firstTac [assumptionTac, Arith.scalarTac]) + progressAsmsOrLookupTheorem keep withArg ids (firstTac [assumptionTac, Arith.scalarTac]) elab "progress" args:progressArgs : tactic => evalProgress args @@ -306,11 +319,11 @@ namespace Test #eval showStoredPSpec #eval showStoredPSpecClass - theorem Scalar.add_spec {ty} {x y : Scalar ty} + theorem Scalar.add_spec1 {ty} {x y : Scalar ty} (hmin : Scalar.min ty ≤ x.val + y.val) (hmax : x.val + y.val ≤ Scalar.max ty) : ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by - progress + progress keep as h with Scalar.add_spec as ⟨ z ⟩ simp [*] /- diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index 3b9b960f..baa8f5c8 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -3,75 +3,6 @@ import Hashmap.Funs open Primitives open Result -namespace List - -theorem index_ne - {α : Type u} [Inhabited α] (l: List α) (i: ℤ) (j: ℤ) (x: α) : - 0 ≤ i → i < l.len → 0 ≤ j → j < l.len → j ≠ i → - (l.update i x).index j = l.index j - := - λ _ _ _ _ _ => match l with - | [] => by simp at * - | hd :: tl => - if h: i = 0 then - have : j ≠ 0 := by scalar_tac - by simp [*] - else if h : j = 0 then - have : i ≠ 0 := by scalar_tac - by simp [*] - else - by - simp [*] - simp at * - apply index_ne <;> scalar_tac - -theorem index_eq - {α : Type u} [Inhabited α] (l: List α) (i: ℤ) (x: α) : - 0 ≤ i → i < l.len → - (l.update i x).index i = x - := - fun _ _ => match l with - | [] => by simp at *; exfalso; scalar_tac -- TODO: exfalso needed. Son FIXME - | hd :: tl => - if h: i = 0 then - by - simp [*] - else - by - simp [*] - simp at * - apply index_eq <;> scalar_tac - -def allP {α : Type u} (l : List α) (p: α → Prop) : Prop := - foldr (fun a r => p a ∧ r) True l - -@[simp] -theorem allP_nil {α : Type u} (p: α → Prop) : allP [] p := - by simp [allP, foldr] - -@[simp] -theorem allP_cons {α : Type u} (hd: α) (tl : List α) (p: α → Prop) : - allP (hd :: tl) p ↔ p hd ∧ allP tl p - := by simp [allP, foldr] - -def pairwise_rel - {α : Type u} (rel : α → α → Prop) (l: List α) : Prop - := match l with - | [] => True - | hd :: tl => allP tl (rel hd) ∧ pairwise_rel rel tl - -@[simp] -theorem pairwise_rel_nil {α : Type u} (rel : α → α → Prop) : - pairwise_rel rel [] - := by simp [pairwise_rel] - -@[simp] -theorem pairwise_rel_cons {α : Type u} (rel : α → α → Prop) (hd: α) (tl: List α) : - pairwise_rel rel (hd :: tl) ↔ allP tl (rel hd) ∧ pairwise_rel rel tl - := by simp [pairwise_rel] - -end List - namespace hashmap namespace List @@ -104,18 +35,16 @@ theorem insert_in_list_spec {α : Type} (key: Usize) (value: α) (ls: List α) : rw [insert_in_list_loop] simp [h] else + have ⟨ b, hi ⟩ := insert_in_list_spec key value tl by - -- TODO: use progress: detect that this is a recursive call, or give - -- the possibility of specifying an identifier - have ⟨ b, hi ⟩ := insert_in_list_spec key value tl exists b simp [insert_in_list, List.lookup] - rw [insert_in_list_loop] -- TODO: Using it in simp leads to infinite recursion + rw [insert_in_list_loop] -- TODO: Using simp leads to infinite recursion simp [h] simp [insert_in_list] at hi exact hi -set_option trace.Progress true +-- Variation: use progress @[pspec] theorem insert_in_list_spec1 {α : Type} (key: Usize) (value: α) (ls: List α) : ∃ b, @@ -134,18 +63,13 @@ theorem insert_in_list_spec1 {α : Type} (key: Usize) (value: α) (ls: List α) simp only [insert_in_list] rw [insert_in_list_loop] conv => rhs; ext; simp [*] - progress as ⟨ b hi ⟩ - - -- TODO: use progress: detect that this is a recursive call, or give - -- the possibility of specifying an identifier - have ⟨ b, hi ⟩ := insert_in_list_spec key value tl + progress keep as heq as ⟨ b hi ⟩ + simp only [insert_in_list] at heq exists b - simp [insert_in_list, List.lookup] - rw [insert_in_list_loop] -- TODO: Using it in simp leads to infinite recursion - simp [h] - simp [insert_in_list] at hi - exact hi + simp only [heq, hi] + simp [*, List.lookup] +-- Variation: use tactics from the beginning @[pspec] theorem insert_in_list_spec2 {α : Type} (key: Usize) (value: α) (ls: List α) : ∃ b, -- cgit v1.3.1 From 03492250b45855fe9db5e0a28a96166607cd84a1 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 20 Jul 2023 14:14:34 +0200 Subject: Make some proofs in Hashmap/Properties.lean and improve progress --- backends/lean/Base/Arith/Int.lean | 2 +- backends/lean/Base/Progress/Base.lean | 25 +++++++--- backends/lean/Base/Progress/Progress.lean | 68 +++++++++------------------ backends/lean/Base/Utils.lean | 32 +++++++++---- tests/lean/Hashmap/Properties.lean | 76 ++++++++++++++++++++++++++----- 5 files changed, 129 insertions(+), 74 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Arith/Int.lean b/backends/lean/Base/Arith/Int.lean index ac011998..fa957293 100644 --- a/backends/lean/Base/Arith/Int.lean +++ b/backends/lean/Base/Arith/Int.lean @@ -198,7 +198,7 @@ def intTac (extraPreprocess : Tactic.TacticM Unit) : Tactic.TacticM Unit := do -- Split the conjunctions in the goal Tactic.allGoals (Utils.repeatTac Utils.splitConjTarget) -- Call linarith - let linarith := + let linarith := do let cfg : Linarith.LinarithConfig := { -- We do this with our custom preprocessing splitNe := false diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index 2fbd24dd..b54bdf7a 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -19,6 +19,7 @@ structure PSpecDesc where -- The existentially quantified variables evars : Array Expr -- The function + fExpr : Expr fName : Name -- The function arguments fLevels : List Level @@ -60,21 +61,30 @@ section Methods m a := do trace[Progress] "Proposition: {th}" -- Dive into the quantified variables and the assumptions - forallTelescope th fun fvars th => do + forallTelescope th.consumeMData fun fvars th => do trace[Progress] "Universally quantified arguments and assumptions: {fvars}" -- Dive into the existentials - existsTelescope th fun evars th => do + existsTelescope th.consumeMData fun evars th => do trace[Progress] "Existentials: {evars}" trace[Progress] "Proposition after stripping the quantifiers: {th}" -- Take the first conjunct - let (th, post) ← optSplitConj th + let (th, post) ← optSplitConj th.consumeMData trace[Progress] "After splitting the conjunction:\n- eq: {th}\n- post: {post}" -- Destruct the equality - let (th, ret) ← destEq th + let (mExpr, ret) ← destEq th.consumeMData trace[Progress] "After splitting the equality:\n- lhs: {th}\n- rhs: {ret}" - -- Destruct the application to get the name - th.consumeMData.withApp fun f args => do - trace[Progress] "After stripping the arguments:\n- f: {f}\n- args: {args}" + -- Destruct the monadic application to dive into the bind, if necessary (this + -- is for when we use `withPSpec` inside of the `progress` tactic), and + -- destruct the application to get the function name + mExpr.consumeMData.withApp fun mf margs => do + trace[Progress] "After stripping the arguments of the monad expression:\n- mf: {mf}\n- margs: {margs}" + let (fExpr, f, args) ← do + if mf.isConst ∧ mf.constName = ``Bind.bind then do + -- Dive into the bind + let fExpr := margs.get! 4 + fExpr.consumeMData.withApp fun f args => pure (fExpr, f, args) + else pure (mExpr, mf, margs) + trace[Progress] "After stripping the arguments of the function call:\n- f: {f}\n- args: {args}" if ¬ f.isConst then throwError "Not a constant: {f}" -- Compute the set of universally quantified variables which appear in the function arguments let allArgsFVars ← args.foldlM (fun hs arg => getFVarIds arg hs) HashSet.empty @@ -94,6 +104,7 @@ section Methods let thDesc := { fvars := fvars evars := evars + fExpr fName := f.constName! fLevels := f.constLevels! args := args diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 1f734415..dabd25b8 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -7,22 +7,6 @@ namespace Progress open Lean Elab Term Meta Tactic open Utils -/- --- TODO: remove -namespace Test - open Primitives - - set_option trace.Progress true - - @[pspec] - theorem vec_index_test (α : Type u) (v: Vec α) (i: Usize) (h: i.val < v.val.length) : - ∃ x, v.index α i = .ret x := by - sorry - - #eval pspecAttr.find? ``Primitives.Vec.index -end Test --/ - inductive TheoremOrLocal where | Theorem (thName : Name) | Local (asm : LocalDecl) @@ -39,7 +23,7 @@ inductive ProgressError | Error (msg : MessageData) deriving Inhabited -def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (keep : Option Name) (ids : Array Name) +def progressWith (fExpr : Expr) (th : TheoremOrLocal) (keep : Option Name) (ids : Array Name) (asmTac : TacticM Unit) : TacticM ProgressError := do /- Apply the theorem We try to match the theorem with the goal @@ -66,7 +50,7 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (keep : Option Name) (ids -- Introduce the existentially quantified variables and the post-condition -- in the context let thBody ← - existsTelescope thExBody fun _evars thBody => do + existsTelescope thExBody.consumeMData fun _evars thBody => do trace[Progress] "After stripping existentials: {thBody}" let (thBody, _) ← optSplitConj thBody trace[Progress] "After splitting the conjunction: {thBody}" @@ -75,9 +59,9 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (keep : Option Name) (ids -- There shouldn't be any existential variables in thBody pure thBody -- Match the body with the target - trace[Progress] "Maching `{thBody}` with `{fnExpr}`" - let ok ← isDefEq thBody fnExpr - if ¬ ok then throwError "Could not unify the theorem with the target:\n- theorem: {thBody}\n- target: {fnExpr}" + trace[Progress] "Matching `{thBody}` with `{fExpr}`" + let ok ← isDefEq thBody fExpr + if ¬ ok then throwError "Could not unify the theorem with the target:\n- theorem: {thBody}\n- target: {fExpr}" let mgoal ← Tactic.getMainGoal postprocessAppMVars `progress mgoal mvars binders true true Term.synthesizeSyntheticMVarsNoPostponing @@ -139,8 +123,9 @@ def progressWith (fnExpr : Expr) (th : TheoremOrLocal) (keep : Option Name) (ids match ids with | [] => pure .Ok -- Stop | nid :: ids => do + trace[Progress] "Splitting post: {hPost}" -- Split - if ← isConj hPost then + if ← isConj (← inferType hPost) then splitConjTac hPost (some (nid, curPostId)) (λ _ nhPost => splitPost nhPost ids) else return (.Error m!"Too many ids provided ({nid :: ids}) not enough conjuncts to split in the postcondition") splitPost hPost ids @@ -175,7 +160,7 @@ def getFirstArg (args : Array Expr) : Option Expr := do /- Helper: try to lookup a theorem and apply it, or continue with another tactic if it fails -/ -def tryLookupApply (keep : Option Name) (ids : Array Name) (asmTac : TacticM Unit) (fnExpr : Expr) +def tryLookupApply (keep : Option Name) (ids : Array Name) (asmTac : TacticM Unit) (fExpr : Expr) (kind : String) (th : Option TheoremOrLocal) (x : TacticM Unit) : TacticM Unit := do let res ← do match th with @@ -187,7 +172,7 @@ def tryLookupApply (keep : Option Name) (ids : Array Name) (asmTac : TacticM Uni -- Apply the theorem let res ← do try - let res ← progressWith fnExpr th keep ids asmTac + let res ← progressWith fExpr th keep ids asmTac pure (some res) catch _ => none match res with @@ -203,18 +188,16 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL let goalTy ← mgoal.getType trace[Progress] "goal: {goalTy}" -- Dive into the goal to lookup the theorem - let (fName, fLevels, args) ← do + let (fExpr, fName, args) ← do withPSpec goalTy fun desc => - -- TODO: check that no universally quantified variables in the arguments - pure (desc.fName, desc.fLevels, desc.args) - -- TODO: this should be in the pspec desc - let fnExpr := mkAppN (.const fName fLevels) args + -- TODO: check that no quantified variables in the arguments + pure (desc.fExpr, desc.fName, desc.args) trace[Progress] "Function: {fName}" -- If the user provided a theorem/assumption: use it. -- Otherwise, lookup one. match withTh with | some th => do - match ← progressWith fnExpr th keep ids asmTac with + match ← progressWith fExpr th keep ids asmTac with | .Ok => return () | .Error msg => throwError msg | none => @@ -223,7 +206,7 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL let decls ← ctx.getDecls for decl in decls.reverse do trace[Progress] "Trying assumption: {decl.userName} : {decl.type}" - let res ← do try progressWith fnExpr (.Local decl) keep ids asmTac catch _ => continue + let res ← do try progressWith fExpr (.Local decl) keep ids asmTac catch _ => continue match res with | .Ok => return () | .Error msg => throwError msg @@ -233,7 +216,7 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL let pspec ← do let thName ← pspecAttr.find? fName pure (thName.map fun th => .Theorem th) - tryLookupApply keep ids asmTac fnExpr "pspec theorem" pspec do + tryLookupApply keep ids asmTac fExpr "pspec theorem" pspec do -- It failed: try to lookup a *class* expr spec theorem (those are more -- specific than class spec theorems) let pspecClassExpr ← do @@ -242,7 +225,7 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL | some arg => do let thName ← pspecClassExprAttr.find? fName arg pure (thName.map fun th => .Theorem th) - tryLookupApply keep ids asmTac fnExpr "pspec class expr theorem" pspecClassExpr do + tryLookupApply keep ids asmTac fExpr "pspec class expr theorem" pspecClassExpr do -- It failed: try to lookup a *class* spec theorem let pspecClass ← do match ← getFirstArgAppName args with @@ -250,7 +233,7 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL | some argName => do let thName ← pspecClassAttr.find? fName argName pure (thName.map fun th => .Theorem th) - tryLookupApply keep ids asmTac fnExpr "pspec class theorem" pspecClass do + tryLookupApply keep ids asmTac fExpr "pspec class theorem" pspecClass do -- Try a recursive call - we try the assumptions of kind "auxDecl" let ctx ← Lean.MonadLCtx.getLCtx let decls ← ctx.getAllDecls @@ -258,7 +241,7 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL | .default | .implDetail => false | .auxDecl => true) for decl in decls.reverse do trace[Progress] "Trying recursive assumption: {decl.userName} : {decl.type}" - let res ← do try progressWith fnExpr (.Local decl) keep ids asmTac catch _ => continue + let res ← do try progressWith fExpr (.Local decl) keep ids asmTac catch _ => continue match res with | .Ok => return () | .Error msg => throwError msg @@ -310,7 +293,6 @@ elab "progress" args:progressArgs : tactic => evalProgress args /- --- TODO: remove namespace Test open Primitives Result @@ -319,22 +301,14 @@ namespace Test #eval showStoredPSpec #eval showStoredPSpecClass - theorem Scalar.add_spec1 {ty} {x y : Scalar ty} + example {ty} {x y : Scalar ty} (hmin : Scalar.min ty ≤ x.val + y.val) (hmax : x.val + y.val ≤ Scalar.max ty) : ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by - progress keep as h with Scalar.add_spec as ⟨ z ⟩ +-- progress keep as h with Scalar.add_spec as ⟨ z ⟩ + progress keep as h simp [*] -/- - @[pspec] - theorem vec_index_test2 (α : Type u) (v: Vec α) (i: Usize) (h: i.val < v.val.length) : - ∃ (x: α), v.index α i = .ret x := by - progress with vec_index_test as ⟨ x ⟩ - simp - - set_option trace.Progress false --/ end Test -/ end Progress diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index 8aa76d8e..44590176 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -308,8 +308,23 @@ def firstTac (tacl : List (TacticM Unit)) : TacticM Unit := do match tacl with | [] => pure () | tac :: tacl => - try tac + -- Should use try ... catch or Lean.observing? + -- Generally speaking we should use Lean.observing? to restore the state, + -- but with tactics the try ... catch variant seems to work + try do + tac + -- Check that there are no remaining goals + let gl ← Tactic.getUnsolvedGoals + if ¬ gl.isEmpty then throwError "tactic failed" catch _ => firstTac tacl +/- let res ← Lean.observing? do + tac + -- Check that there are no remaining goals + let gl ← Tactic.getUnsolvedGoals + if ¬ gl.isEmpty then throwError "tactic failed" + match res with + | some _ => pure () + | none => firstTac tacl -/ -- Split the goal if it is a conjunction def splitConjTarget : TacticM Unit := do @@ -424,12 +439,13 @@ def splitExistsTac (h : Expr) (optId : Option Name) (k : Expr → Expr → Tacti let hTy ← inferType h if isExists hTy then do -- Try to use the user-provided names - let altVarNames ← - match optId with - | none => pure #[] - | some id => do - let hDecl ← h.fvarId!.getDecl - pure #[{ varNames := [id, hDecl.userName] }] + let altVarNames ← do + let hDecl ← h.fvarId!.getDecl + let id ← do + match optId with + | none => mkFreshUserName `x + | some id => pure id + pure #[{ varNames := [id, hDecl.userName] }] let newGoals ← goal.cases h.fvarId! altVarNames -- There should be exactly one goal match newGoals.toList with @@ -511,7 +527,7 @@ example (h : a ∧ b) : a := by example (h : ∃ x y z, x + y + z ≥ 0) : ∃ x, x ≥ 0 := by split_all_exists h - rename_i x y z h + rename_i x y z exists x + y + z /- Call the simp tactic. diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index baa8f5c8..e065bb36 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -21,8 +21,9 @@ end List namespace HashMap -@[pspec] -theorem insert_in_list_spec {α : Type} (key: Usize) (value: α) (ls: List α) : +abbrev Core.List := _root_.List + +theorem insert_in_list_spec0 {α : Type} (key: Usize) (value: α) (ls: List α) : ∃ b, insert_in_list α key value ls = ret b ∧ (b ↔ List.lookup ls.v key = none) @@ -35,7 +36,7 @@ theorem insert_in_list_spec {α : Type} (key: Usize) (value: α) (ls: List α) : rw [insert_in_list_loop] simp [h] else - have ⟨ b, hi ⟩ := insert_in_list_spec key value tl + have ⟨ b, hi ⟩ := insert_in_list_spec0 key value tl by exists b simp [insert_in_list, List.lookup] @@ -45,7 +46,6 @@ theorem insert_in_list_spec {α : Type} (key: Usize) (value: α) (ls: List α) : exact hi -- Variation: use progress -@[pspec] theorem insert_in_list_spec1 {α : Type} (key: Usize) (value: α) (ls: List α) : ∃ b, insert_in_list α key value ls = ret b ∧ @@ -70,7 +70,6 @@ theorem insert_in_list_spec1 {α : Type} (key: Usize) (value: α) (ls: List α) simp [*, List.lookup] -- Variation: use tactics from the beginning -@[pspec] theorem insert_in_list_spec2 {α : Type} (key: Usize) (value: α) (ls: List α) : ∃ b, insert_in_list α key value ls = ret b ∧ @@ -91,10 +90,10 @@ theorem insert_in_list_spec2 {α : Type} (key: Usize) (value: α) (ls: List α) progress as ⟨ b h ⟩ simp [*] -@[pspec] theorem insert_in_list_back_spec {α : Type} (key: Usize) (value: α) (l0: List α) : ∃ l1, insert_in_list_back α key value l0 = ret l1 ∧ + -- We update the binding List.lookup l1.v key = value ∧ (∀ k, k ≠ key → List.lookup l1.v k = List.lookup l0.v k) := match l0 with @@ -112,11 +111,66 @@ theorem insert_in_list_back_spec {α : Type} (key: Usize) (value: α) (l0: List simp [insert_in_list_back, List.lookup] rw [insert_in_list_loop_back] simp [h, List.lookup] - have ⟨tl0 , _, _ ⟩ := insert_in_list_back_spec key value tl -- TODO: Use progress - simp [insert_in_list_back] at * - simp [List.lookup, *] - simp (config := {contextual := true}) [*] - + progress keep as heq as ⟨ tl hp1 hp2 ⟩ + simp [insert_in_list_back] at heq + simp (config := {contextual := true}) [*, List.lookup] + +def distinct_keys (ls : Core.List (Usize × α)) := ls.pairwise_rel (λ x y => x.fst ≠ y.fst) + +def hash_mod_key (k : Usize) (l : Int) : Int := + match hash_key k with + | .ret k => k.val % l + | _ => 0 + +def slot_s_inv_hash (l i : Int) (ls : Core.List (Usize × α)) : Prop := + ls.allP (λ (k, _) => hash_mod_key k l = i) + +@[simp] +def slot_s_inv (l i : Int) (ls : Core.List (Usize × α)) : Prop := + distinct_keys ls ∧ + slot_s_inv_hash l i ls + +def slot_t_inv (l i : Int) (s : List α) : Prop := slot_s_inv l i s.v + +@[pspec] +theorem insert_in_list_back_spec1 {α : Type} (l : Int) (key: Usize) (value: α) (l0: List α) + (hinv : slot_s_inv_hash l (hash_mod_key key l) l0.v) : + ∃ l1, + insert_in_list_back α key value l0 = ret l1 ∧ + -- We update the binding + List.lookup l1.v key = value ∧ + (∀ k, k ≠ key → List.lookup l1.v k = List.lookup l0.v k) ∧ + -- We preserve part of the key invariant + slot_s_inv_hash l (hash_mod_key key l) l1.v + := match l0 with + | .Nil => by + simp [insert_in_list_back, insert_in_list_loop_back, List.lookup, List.v, slot_s_inv_hash] + tauto + | .Cons k v tl0 => + if h: k = key then + by + simp [insert_in_list_back, List.lookup] + rw [insert_in_list_loop_back] + simp [h, List.lookup] + constructor + . intros; simp [*] + . simp [List.v, slot_s_inv_hash] at * + simp [*] + else + by + simp [insert_in_list_back, List.lookup] + rw [insert_in_list_loop_back] + simp [h, List.lookup] + have : slot_s_inv_hash l (hash_mod_key key l) (List.v tl0) := by + simp_all [List.v, slot_s_inv_hash] + progress keep as heq as ⟨ tl1 hp1 hp2 hp3 ⟩ + simp only [insert_in_list_back] at heq + have : slot_s_inv_hash l (hash_mod_key key l) (List.v (List.Cons k v tl1)) := by + simp [List.v, slot_s_inv_hash] at * + simp [*] + simp (config := {contextual := true}) [*, List.lookup] + + end HashMap end hashmap -- cgit v1.3.1 From 9b1498aa7fe014ac430467919504d35b0a688934 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 20 Jul 2023 16:13:35 +0200 Subject: Fix a naming issue with progress --- backends/lean/Base/Progress/Progress.lean | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index dabd25b8..1c509775 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -118,17 +118,17 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) (keep : Option Name) (ids match hPost with | none => do return (.Error m!"Too many ids provided ({ids}): there is no postcondition to split") | some hPost => pure hPost - let curPostId := (← hPost.fvarId!.getDecl).userName - let rec splitPost (hPost : Expr) (ids : List Name) : TacticM ProgressError := do + let rec splitPost (prevId : Name) (hPost : Expr) (ids : List Name) : TacticM ProgressError := do match ids with | [] => pure .Ok -- Stop | nid :: ids => do trace[Progress] "Splitting post: {hPost}" -- Split if ← isConj (← inferType hPost) then - splitConjTac hPost (some (nid, curPostId)) (λ _ nhPost => splitPost nhPost ids) + splitConjTac hPost (some (prevId, nid)) (λ _ nhPost => splitPost nid nhPost ids) else return (.Error m!"Too many ids provided ({nid :: ids}) not enough conjuncts to split in the postcondition") - splitPost hPost ids + let curPostId := (← hPost.fvarId!.getDecl).userName + splitPost curPostId hPost ids else return .Ok match res with | .Error _ => return res -- Can we get there? We're using "return" -- cgit v1.3.1 From 2dd56a51df01421fe7766858c9d37998db4123b5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 25 Jul 2023 11:53:49 +0200 Subject: Improve the syntax of progress: `as ⟨ x, y .. ⟩` --- backends/lean/Base/Progress/Progress.lean | 77 ++++++++++++++++++------------- backends/lean/Base/Utils.lean | 61 ++++++++++++++++++------ tests/lean/Hashmap/Properties.lean | 34 ++------------ 3 files changed, 98 insertions(+), 74 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 1c509775..c8f94e9e 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -23,7 +23,8 @@ inductive ProgressError | Error (msg : MessageData) deriving Inhabited -def progressWith (fExpr : Expr) (th : TheoremOrLocal) (keep : Option Name) (ids : Array Name) +def progressWith (fExpr : Expr) (th : TheoremOrLocal) + (keep : Option Name) (ids : Array Name) (splitPost : Bool) (asmTac : TacticM Unit) : TacticM ProgressError := do /- Apply the theorem We try to match the theorem with the goal @@ -112,24 +113,31 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) (keep : Option Name) (ids mgoal.tryClearMany #[hEq.fvarId!] setGoals (mgoal :: (← getUnsolvedGoals)) trace[Progress] "Goal after splitting eq and post and simplifying the target: {mgoal}" - -- Continue splitting following the ids provided by the user - if ¬ ids.isEmpty then - let hPost ← - match hPost with - | none => do return (.Error m!"Too many ids provided ({ids}): there is no postcondition to split") - | some hPost => pure hPost - let rec splitPost (prevId : Name) (hPost : Expr) (ids : List Name) : TacticM ProgressError := do + -- Continue splitting following the post following the user's instructions + match hPost with + | none => + -- Sanity check + if ¬ ids.isEmpty then + return (.Error m!"Too many ids provided ({ids}): there is no postcondition to split") + else return .Ok + | some hPost => do + let rec splitPostWithIds (prevId : Name) (hPost : Expr) (ids : List Name) : TacticM ProgressError := do match ids with - | [] => pure .Ok -- Stop + | [] => + /- We used all the user provided ids. + Split the remaining conjunctions by using fresh ids if the user + instructed to fully split the post-condition, otherwise stop -/ + if splitPost then + splitFullConjTac hPost (λ _ => pure .Ok) + else pure .Ok | nid :: ids => do trace[Progress] "Splitting post: {hPost}" -- Split if ← isConj (← inferType hPost) then - splitConjTac hPost (some (prevId, nid)) (λ _ nhPost => splitPost nid nhPost ids) + splitConjTac hPost (some (prevId, nid)) (λ _ nhPost => splitPostWithIds nid nhPost ids) else return (.Error m!"Too many ids provided ({nid :: ids}) not enough conjuncts to split in the postcondition") let curPostId := (← hPost.fvarId!.getDecl).userName - splitPost curPostId hPost ids - else return .Ok + splitPostWithIds curPostId hPost ids match res with | .Error _ => return res -- Can we get there? We're using "return" | .Ok => @@ -160,7 +168,8 @@ def getFirstArg (args : Array Expr) : Option Expr := do /- Helper: try to lookup a theorem and apply it, or continue with another tactic if it fails -/ -def tryLookupApply (keep : Option Name) (ids : Array Name) (asmTac : TacticM Unit) (fExpr : Expr) +def tryLookupApply (keep : Option Name) (ids : Array Name) (splitPost : Bool) + (asmTac : TacticM Unit) (fExpr : Expr) (kind : String) (th : Option TheoremOrLocal) (x : TacticM Unit) : TacticM Unit := do let res ← do match th with @@ -172,7 +181,7 @@ def tryLookupApply (keep : Option Name) (ids : Array Name) (asmTac : TacticM Uni -- Apply the theorem let res ← do try - let res ← progressWith fExpr th keep ids asmTac + let res ← progressWith fExpr th keep ids splitPost asmTac pure (some res) catch _ => none match res with @@ -181,7 +190,8 @@ def tryLookupApply (keep : Option Name) (ids : Array Name) (asmTac : TacticM Uni | none => x -- The array of ids are identifiers to use when introducing fresh variables -def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrLocal) (ids : Array Name) (asmTac : TacticM Unit) : TacticM Unit := do +def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrLocal) + (ids : Array Name) (splitPost : Bool) (asmTac : TacticM Unit) : TacticM Unit := do withMainContext do -- Retrieve the goal let mgoal ← Tactic.getMainGoal @@ -197,7 +207,7 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL -- Otherwise, lookup one. match withTh with | some th => do - match ← progressWith fExpr th keep ids asmTac with + match ← progressWith fExpr th keep ids splitPost asmTac with | .Ok => return () | .Error msg => throwError msg | none => @@ -206,7 +216,7 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL let decls ← ctx.getDecls for decl in decls.reverse do trace[Progress] "Trying assumption: {decl.userName} : {decl.type}" - let res ← do try progressWith fExpr (.Local decl) keep ids asmTac catch _ => continue + let res ← do try progressWith fExpr (.Local decl) keep ids splitPost asmTac catch _ => continue match res with | .Ok => return () | .Error msg => throwError msg @@ -216,7 +226,7 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL let pspec ← do let thName ← pspecAttr.find? fName pure (thName.map fun th => .Theorem th) - tryLookupApply keep ids asmTac fExpr "pspec theorem" pspec do + 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) let pspecClassExpr ← do @@ -225,7 +235,7 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL | some arg => do let thName ← pspecClassExprAttr.find? fName arg pure (thName.map fun th => .Theorem th) - tryLookupApply keep ids asmTac fExpr "pspec class expr theorem" pspecClassExpr do + tryLookupApply keep ids splitPost asmTac fExpr "pspec class expr theorem" pspecClassExpr do -- It failed: try to lookup a *class* spec theorem let pspecClass ← do match ← getFirstArgAppName args with @@ -233,7 +243,7 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL | some argName => do let thName ← pspecClassAttr.find? fName argName pure (thName.map fun th => .Theorem th) - tryLookupApply keep ids asmTac fExpr "pspec class theorem" pspecClass do + tryLookupApply keep ids splitPost asmTac fExpr "pspec class theorem" pspecClass do -- Try a recursive call - we try the assumptions of kind "auxDecl" let ctx ← Lean.MonadLCtx.getLCtx let decls ← ctx.getAllDecls @@ -241,14 +251,14 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL | .default | .implDetail => false | .auxDecl => true) for decl in decls.reverse do trace[Progress] "Trying recursive assumption: {decl.userName} : {decl.type}" - let res ← do try progressWith fExpr (.Local decl) keep ids asmTac catch _ => continue + let res ← do try progressWith fExpr (.Local decl) keep ids splitPost asmTac catch _ => continue match res with | .Ok => return () | .Error msg => throwError msg -- Nothing worked: failed throwError "Progress failed" -syntax progressArgs := ("keep" ("as" (ident))?)? ("with" ident)? ("as" " ⟨ " (ident)+ " ⟩")? +syntax progressArgs := ("keep" ("as" (ident))?)? ("with" ident)? ("as" " ⟨ " ident,* " .."? " ⟩")? def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do let args := args.raw @@ -263,8 +273,8 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do else do pure (some (← mkFreshUserName `h)) else pure none trace[Progress] "Keep: {keep}" - let withArg := (args.get! 1).getArgs let withArg ← do + let withArg := (args.get! 1).getArgs if withArg.size > 0 then let id := withArg.get! 1 trace[Progress] "With arg: {id}" @@ -283,20 +293,25 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do | id :: _ => pure (some (.Theorem id)) else pure none - let args := (args.get! 2).getArgs - let args := (args.get! 2).getArgs - let ids := args.map Syntax.getId + let ids := + let args := (args.get! 2).getArgs + let args := (args.get! 2).getSepArgs + args.map Syntax.getId trace[Progress] "User-provided ids: {ids}" - progressAsmsOrLookupTheorem keep withArg ids (firstTac [assumptionTac, Arith.scalarTac]) + let splitPost : Bool := + let args := (args.get! 2).getArgs + (args.get! 3).getArgs.size > 0 + trace[Progress] "Split post: {splitPost}" + progressAsmsOrLookupTheorem keep withArg ids splitPost (firstTac [assumptionTac, Arith.scalarTac]) elab "progress" args:progressArgs : tactic => evalProgress args -/- -namespace Test +/-namespace Test open Primitives Result set_option trace.Progress true + set_option pp.rawOnError true #eval showStoredPSpec #eval showStoredPSpecClass @@ -306,9 +321,9 @@ namespace Test (hmax : x.val + y.val ≤ Scalar.max ty) : ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by -- progress keep as h with Scalar.add_spec as ⟨ z ⟩ - progress keep as h + progress keep as h as ⟨ z, h1 .. ⟩ simp [*] -end Test -/ +end Test-/ end Progress diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index f014e112..3b3d4729 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -499,7 +499,10 @@ def splitConjTac (h : Expr) (optIds : Option (Name × Name)) (k : Expr → Expr -- Try to use the user-provided names let altVarNames ← match optIds with - | none => pure #[] + | none => do + let id0 ← mkFreshUserName `h + let id1 ← mkFreshUserName `h + pure #[{ varNames := [id0, id1] }] | some (id0, id1) => do pure #[{ varNames := [id0, id1] }] let newGoals ← goal.cases h.fvarId! altVarNames @@ -518,29 +521,61 @@ def splitConjTac (h : Expr) (optIds : Option (Name × Name)) (k : Expr → Expr else throwError "Not a conjunction" -elab "split_conj " n:ident : tactic => do +-- Tactic to fully split a conjunction +partial def splitFullConjTacAux [Inhabited α] [Nonempty α] (l : List Expr) (h : Expr) (k : List Expr → TacticM α) : TacticM α := do + try + splitConjTac h none (λ h1 h2 => + splitFullConjTacAux l h1 (λ l1 => + splitFullConjTacAux l1 h2 (λ l2 => + k l2))) + catch _ => + k (h :: l) + +-- Tactic to fully split a conjunction +def splitFullConjTac [Inhabited α] [Nonempty α] (h : Expr) (k : List Expr → TacticM α) : TacticM α := do + splitFullConjTacAux [] h (λ l => k l.reverse) + +syntax optAtArgs := ("at" ident)? +def elabOptAtArgs (args : TSyntax `Utils.optAtArgs) : TacticM (Option Expr) := do withMainContext do - let decl ← Lean.Meta.getLocalDeclFromUserName n.getId - let fvar := mkFVar decl.fvarId - splitConjTac fvar none (fun _ _ => pure ()) + let args := (args.raw.getArgs.get! 0).getArgs + if args.size > 0 then do + let n := (args.get! 1).getId + let decl ← Lean.Meta.getLocalDeclFromUserName n + let fvar := mkFVar decl.fvarId + pure (some fvar) + else + pure none -elab "split_all_exists " n:ident : tactic => do +elab "split_conj" args:optAtArgs : tactic => do + withMainContext do + match ← elabOptAtArgs args with + | some fvar => + splitConjTac fvar none (fun _ _ => pure ()) + | none => + splitConjTarget + +elab "split_conjs" args:optAtArgs : tactic => do + withMainContext do + match ← elabOptAtArgs args with + | some fvar => + splitFullConjTac fvar (fun _ => pure ()) + | none => + repeatTac splitConjTarget + +elab "split_existsl" " at " n:ident : tactic => do withMainContext do let decl ← Lean.Meta.getLocalDeclFromUserName n.getId let fvar := mkFVar decl.fvarId splitAllExistsTac fvar [] (fun _ _ => pure ()) -elab "split_target_conjs" : tactic => - withMainContext do - repeatTac splitConjTarget - example (h : a ∧ b) : a := by - split_all_exists h - split_conj h + split_existsl at h + split_conj at h assumption example (h : ∃ x y z, x + y + z ≥ 0) : ∃ x, x ≥ 0 := by - split_all_exists h + split_existsl at h rename_i x y z exists x + y + z diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index dce33fa4..de6bf636 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -94,7 +94,7 @@ theorem insert_in_list_spec1 {α : Type} (key: Usize) (value: α) (ls: List α) simp only [insert_in_list] rw [insert_in_list_loop] conv => rhs; ext; simp [*] - progress keep as heq as ⟨ b hi ⟩ + progress keep as heq as ⟨ b, hi ⟩ simp only [insert_in_list] at heq exists b @@ -116,35 +116,9 @@ theorem insert_in_list_spec2 {α : Type} (key: Usize) (value: α) (ls: List α) conv => rhs; ext; left; simp [h] -- TODO: Simplify simp only [insert_in_list] at ih; -- TODO: give the possibility of using underscores - progress as ⟨ b h ⟩ + progress as ⟨ b, h ⟩ simp [*] -theorem insert_in_list_back_spec {α : Type} (key: Usize) (value: α) (l0: List α) : - ∃ l1, - insert_in_list_back α key value l0 = ret l1 ∧ - -- We update the binding - l1.lookup key = value ∧ - (∀ k, k ≠ key → l1.lookup k = l0.lookup k) - := match l0 with - | .Nil => by - simp (config := {contextual := true}) [insert_in_list_back, insert_in_list_loop_back] - | .Cons k v tl => - if h: k = key then - by - simp [insert_in_list_back] - rw [insert_in_list_loop_back] - simp [h] - intro k1 h1 - simp [*] - else - by - simp [insert_in_list_back] - rw [insert_in_list_loop_back] - simp [h] - progress keep as heq as ⟨ tl hp1 hp2 ⟩ - simp [insert_in_list_back] at heq - simp (config := {contextual := true}) [*] - def distinct_keys (ls : Core.List (Usize × α)) := ls.pairwise_rel (λ x y => x.fst ≠ y.fst) def hash_mod_key (k : Usize) (l : Int) : Int := @@ -190,7 +164,7 @@ theorem insert_in_list_back_spec_aux {α : Type} (l : Int) (key: Usize) (value: simp [insert_in_list_back] rw [insert_in_list_loop_back] simp [h] - split_target_conjs + split_conjs . intros; simp [*] . simp [List.v, slot_s_inv_hash] at * simp [*] @@ -206,7 +180,7 @@ theorem insert_in_list_back_spec_aux {α : Type} (l : Int) (key: Usize) (value: have : distinct_keys (List.v tl0) := by checkpoint simp [distinct_keys] at hdk simp [hdk, distinct_keys] - progress keep as heq as ⟨ tl1 hp1 hp2 hp3 hp4 hp5 hp6 ⟩ + progress keep as heq as ⟨ tl1 .. ⟩ simp only [insert_in_list_back] at heq have : slot_s_inv_hash l (hash_mod_key key l) (List.v (List.Cons k v tl1)) := by checkpoint simp [List.v, slot_s_inv_hash] at * -- cgit v1.3.1 From c652e97f7ab13164150331b4aa3f2e7ef11d24b9 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 25 Jul 2023 12:13:20 +0200 Subject: Add the possibility of using "_" as ident for progress --- backends/lean/Base/Progress/Progress.lean | 37 ++++++++++++++++++------------- backends/lean/Base/Utils.lean | 7 ++++-- 2 files changed, 26 insertions(+), 18 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index c8f94e9e..c0ddc63d 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -24,7 +24,7 @@ inductive ProgressError deriving Inhabited def progressWith (fExpr : Expr) (th : TheoremOrLocal) - (keep : Option Name) (ids : Array Name) (splitPost : Bool) + (keep : Option Name) (ids : Array (Option Name)) (splitPost : Bool) (asmTac : TacticM Unit) : TacticM ProgressError := do /- Apply the theorem We try to match the theorem with the goal @@ -90,13 +90,14 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) -- For the conjunctions, we split according once to separate the equality `f ... = .ret ...` -- from the postcondition, if there is, then continue to split the postcondition if there -- are remaining ids. - let splitEqAndPost (k : Expr → Option Expr → List Name → TacticM ProgressError) : TacticM ProgressError := do + let splitEqAndPost (k : Expr → Option Expr → List (Option Name) → TacticM ProgressError) : TacticM ProgressError := do if ← isConj (← inferType h) then do let hName := (← h.fvarId!.getDecl).userName - let (optId, ids) := listTryPopHead ids - let optIds ← match optId with - | none => do pure (some (hName, ← mkFreshUserName `h)) - | some id => do pure (some (hName, id)) + let (optIds, ids) ← do + match ids with + | [] => do pure (some (hName, ← mkFreshUserName `h), []) + | none :: ids => do pure (some (hName, ← mkFreshUserName `h), ids) + | some id :: ids => do pure (some (hName, id), ids) splitConjTac h optIds (fun hEq hPost => k hEq (some hPost) ids) else k h none ids -- Simplify the target by using the equality and some monad simplifications, @@ -121,8 +122,8 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) return (.Error m!"Too many ids provided ({ids}): there is no postcondition to split") else return .Ok | some hPost => do - let rec splitPostWithIds (prevId : Name) (hPost : Expr) (ids : List Name) : TacticM ProgressError := do - match ids with + let rec splitPostWithIds (prevId : Name) (hPost : Expr) (ids0 : List (Option Name)) : TacticM ProgressError := do + match ids0 with | [] => /- We used all the user provided ids. Split the remaining conjunctions by using fresh ids if the user @@ -133,9 +134,13 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) | nid :: ids => do trace[Progress] "Splitting post: {hPost}" -- Split + let nid ← do + match nid with + | none => mkFreshUserName `h + | some nid => pure nid if ← isConj (← inferType hPost) then splitConjTac hPost (some (prevId, nid)) (λ _ nhPost => splitPostWithIds nid nhPost ids) - else return (.Error m!"Too many ids provided ({nid :: ids}) not enough conjuncts to split in the postcondition") + else return (.Error m!"Too many ids provided ({ids0}) not enough conjuncts to split in the postcondition") let curPostId := (← hPost.fvarId!.getDecl).userName splitPostWithIds curPostId hPost ids match res with @@ -168,7 +173,7 @@ def getFirstArg (args : Array Expr) : Option Expr := do /- Helper: try to lookup a theorem and apply it, or continue with another tactic if it fails -/ -def tryLookupApply (keep : Option Name) (ids : Array Name) (splitPost : Bool) +def tryLookupApply (keep : Option Name) (ids : Array (Option Name)) (splitPost : Bool) (asmTac : TacticM Unit) (fExpr : Expr) (kind : String) (th : Option TheoremOrLocal) (x : TacticM Unit) : TacticM Unit := do let res ← do @@ -191,7 +196,7 @@ def tryLookupApply (keep : Option Name) (ids : Array Name) (splitPost : Bool) -- The array of ids are identifiers to use when introducing fresh variables def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrLocal) - (ids : Array Name) (splitPost : Bool) (asmTac : TacticM Unit) : TacticM Unit := do + (ids : Array (Option Name)) (splitPost : Bool) (asmTac : TacticM Unit) : TacticM Unit := do withMainContext do -- Retrieve the goal let mgoal ← Tactic.getMainGoal @@ -258,7 +263,7 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL -- Nothing worked: failed throwError "Progress failed" -syntax progressArgs := ("keep" ("as" (ident))?)? ("with" ident)? ("as" " ⟨ " ident,* " .."? " ⟩")? +syntax progressArgs := ("keep" ("as" (ident))?)? ("with" ident)? ("as" " ⟨ " (ident <|> "_"),* " .."? " ⟩")? def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do let args := args.raw @@ -296,7 +301,7 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do let ids := let args := (args.get! 2).getArgs let args := (args.get! 2).getSepArgs - args.map Syntax.getId + args.map (λ s => if s.isIdent then some s.getId else none) trace[Progress] "User-provided ids: {ids}" let splitPost : Bool := let args := (args.get! 2).getArgs @@ -307,7 +312,7 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do elab "progress" args:progressArgs : tactic => evalProgress args -/-namespace Test +/- namespace Test open Primitives Result set_option trace.Progress true @@ -321,9 +326,9 @@ elab "progress" args:progressArgs : tactic => (hmax : x.val + y.val ≤ Scalar.max ty) : ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by -- progress keep as h with Scalar.add_spec as ⟨ z ⟩ - progress keep as h as ⟨ z, h1 .. ⟩ + progress keep as h as ⟨ x, h1 .. ⟩ simp [*] -end Test-/ +end Test -/ end Progress diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index 3b3d4729..66497a49 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -484,9 +484,12 @@ def listTryPopHead (ls : List α) : Option α × List α := If `ids` is not empty, we use it to name the introduced variables. We transmit the stripped expression and the remaining ids to the continuation. -/ -partial def splitAllExistsTac [Inhabited α] (h : Expr) (ids : List Name) (k : Expr → List Name → TacticM α) : TacticM α := do +partial def splitAllExistsTac [Inhabited α] (h : Expr) (ids : List (Option Name)) (k : Expr → List (Option Name) → TacticM α) : TacticM α := do try - let (optId, ids) := listTryPopHead ids + let (optId, ids) := + match ids with + | [] => (none, []) + | x :: ids => (x, ids) splitExistsTac h optId (fun _ body => splitAllExistsTac body ids k) catch _ => k h ids -- cgit v1.3.1 From 876137dff361620d8ade1a4ee94fa9274df0bdc6 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 25 Jul 2023 14:08:44 +0200 Subject: Improve int_tac and scalar_tac --- backends/lean/Base/Arith/Int.lean | 63 +++++++++++++++++++++++++++---- backends/lean/Base/Arith/Scalar.lean | 6 +-- backends/lean/Base/IList/IList.lean | 12 ++---- backends/lean/Base/Primitives/Vec.lean | 25 ++++++------ backends/lean/Base/Progress/Progress.lean | 13 ++++++- 5 files changed, 87 insertions(+), 32 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Arith/Int.lean b/backends/lean/Base/Arith/Int.lean index fa957293..3415866e 100644 --- a/backends/lean/Base/Arith/Int.lean +++ b/backends/lean/Base/Arith/Int.lean @@ -24,12 +24,29 @@ class PropHasImp (x : Prop) where concl : Prop prop : x → concl +instance (p : Int → Prop) : HasIntProp (Subtype p) where + prop_ty := λ x => p x + prop := λ x => x.property + -- This also works for `x ≠ y` because this expression reduces to `¬ x = y` -- and `Ne` is marked as `reducible` instance (x y : Int) : PropHasImp (¬ x = y) where concl := x < y ∨ x > y prop := λ (h:x ≠ y) => ne_is_lt_or_gt h +-- Check if a proposition is a linear integer proposition. +-- We notably use this to check the goals. +class IsLinearIntProp (x : Prop) where + +instance (x y : Int) : IsLinearIntProp (x < y) where +instance (x y : Int) : IsLinearIntProp (x > y) where +instance (x y : Int) : IsLinearIntProp (x ≤ y) where +instance (x y : Int) : IsLinearIntProp (x ≥ y) where +instance (x y : Int) : IsLinearIntProp (x ≥ y) where +/- It seems we don't need to do any special preprocessing when the *goal* + has the following shape - I guess `linarith` automatically calls `intro` -/ +instance (x y : Int) : IsLinearIntProp (¬ x = y) where + open Lean Lean.Elab Lean.Meta -- Explore a term by decomposing the applications (we explore the applied @@ -189,14 +206,27 @@ def intTacPreprocess (extraPreprocess : Tactic.TacticM Unit) : Tactic.TacticM U elab "int_tac_preprocess" : tactic => intTacPreprocess (do pure ()) -def intTac (extraPreprocess : Tactic.TacticM Unit) : Tactic.TacticM Unit := do +-- Check if the goal is a linear arithmetic goal +def goalIsLinearInt : Tactic.TacticM Bool := do + Tactic.withMainContext do + let gty ← Tactic.getMainTarget + match ← trySynthInstance (← mkAppM ``IsLinearIntProp #[gty]) with + | .some _ => pure true + | _ => pure false + +def intTac (splitGoalConjs : Bool) (extraPreprocess : Tactic.TacticM Unit) : Tactic.TacticM Unit := do Tactic.withMainContext do Tactic.focus do + let g ← Tactic.getMainGoal + trace[Arith] "Original goal: {g}" + -- Introduce all the universally quantified variables (includes the assumptions) + let (_, g) ← g.intros + Tactic.setGoals [g] -- Preprocess - wondering if we should do this before or after splitting -- the goal. I think before leads to a smaller proof term? Tactic.allGoals (intTacPreprocess extraPreprocess) -- Split the conjunctions in the goal - Tactic.allGoals (Utils.repeatTac Utils.splitConjTarget) + if splitGoalConjs then Tactic.allGoals (Utils.repeatTac Utils.splitConjTarget) -- Call linarith let linarith := do let cfg : Linarith.LinarithConfig := { @@ -204,10 +234,25 @@ def intTac (extraPreprocess : Tactic.TacticM Unit) : Tactic.TacticM Unit := do splitNe := false } Tactic.liftMetaFinishingTactic <| Linarith.linarith false [] cfg - Tactic.allGoals linarith - -elab "int_tac" : tactic => - intTac (do pure ()) + Tactic.allGoals do + -- We check if the goal is a linear arithmetic goal: if yes, we directly + -- call linarith, otherwise we first apply exfalso (we do this because + -- linarith is too general and sometimes fails to do this correctly). + if ← goalIsLinearInt then do + trace[Arith] "linarith goal: {← Tactic.getMainGoal}" + linarith + else do + let g ← Tactic.getMainGoal + let gs ← g.apply (Expr.const ``False.elim [.zero]) + let goals ← Tactic.getGoals + Tactic.setGoals (gs ++ goals) + Tactic.allGoals do + trace[Arith] "linarith goal: {← Tactic.getMainGoal}" + linarith + +elab "int_tac" args:(" split_goal"?): tactic => + let split := args.raw.getArgs.size > 0 + intTac split (do pure ()) example (x : Int) (h0: 0 ≤ x) (h1: x ≠ 0) : 0 < x := by int_tac_preprocess @@ -219,10 +264,14 @@ example (x : Int) (h0: 0 ≤ x) (h1: x ≠ 0) : 0 < x := by -- Checking that things append correctly when there are several disjunctions example (x y : Int) (h0: 0 ≤ x) (h1: x ≠ 0) (h2 : 0 ≤ y) (h3 : y ≠ 0) : 0 < x ∧ 0 < y := by - int_tac + int_tac split_goal -- Checking that things append correctly when there are several disjunctions example (x y : Int) (h0: 0 ≤ x) (h1: x ≠ 0) (h2 : 0 ≤ y) (h3 : y ≠ 0) : 0 < x ∧ 0 < y ∧ x + y ≥ 2 := by + int_tac split_goal + +-- Checking that we can prove exfalso +example (a : Prop) (x : Int) (h0: 0 < x) (h1: x < 0) : a := by int_tac end Arith diff --git a/backends/lean/Base/Arith/Scalar.lean b/backends/lean/Base/Arith/Scalar.lean index f8903ecf..a56ea08b 100644 --- a/backends/lean/Base/Arith/Scalar.lean +++ b/backends/lean/Base/Arith/Scalar.lean @@ -28,11 +28,11 @@ elab "scalar_tac_preprocess" : tactic => intTacPreprocess scalarTacExtraPreprocess -- A tactic to solve linear arithmetic goals in the presence of scalars -def scalarTac : Tactic.TacticM Unit := do - intTac scalarTacExtraPreprocess +def scalarTac (splitGoalConjs : Bool) : Tactic.TacticM Unit := do + intTac splitGoalConjs scalarTacExtraPreprocess elab "scalar_tac" : tactic => - scalarTac + scalarTac false instance (ty : ScalarTy) : HasIntProp (Scalar ty) where -- prop_ty is inferred diff --git a/backends/lean/Base/IList/IList.lean b/backends/lean/Base/IList/IList.lean index 1773e593..2443b1a6 100644 --- a/backends/lean/Base/IList/IList.lean +++ b/backends/lean/Base/IList/IList.lean @@ -46,21 +46,18 @@ theorem indexOpt_bounds (ls : List α) (i : Int) : ls.indexOpt i = none ↔ i < 0 ∨ ls.len ≤ i := match ls with | [] => - have : ¬ (i < 0) → 0 ≤ i := by intro; linarith -- TODO: simplify (we could boost int_tac) + have : ¬ (i < 0) → 0 ≤ i := by int_tac by simp; tauto | _ :: tl => have := indexOpt_bounds tl (i - 1) if h: i = 0 then by simp [*]; - -- TODO: int_tac/scalar_tac should also explore the goal! - have := tl.len_pos - linarith + int_tac else by simp [*] constructor <;> intros <;> - -- TODO: tactic to split all disjunctions - rename_i hor <;> cases hor <;> + casesm* _ ∨ _ <;> -- splits all the disjunctions first | left; int_tac | right; int_tac theorem indexOpt_eq_index [Inhabited α] (ls : List α) (i : Int) : @@ -126,7 +123,6 @@ theorem length_update (ls : List α) (i : Int) (x : α) : (ls.update i x).length theorem len_update (ls : List α) (i : Int) (x : α) : (ls.update i x).len = ls.len := by simp [len_eq_length] - theorem left_length_eq_append_eq (l1 l2 l1' l2' : List α) (heq : l1.length = l1'.length) : l1 ++ l2 = l1' ++ l2' ↔ l1 = l1' ∧ l2 = l2' := by revert l1' @@ -203,7 +199,7 @@ theorem index_eq (l.update i x).index i = x := fun _ _ => match l with - | [] => by simp at *; exfalso; scalar_tac -- TODO: exfalso needed. Son FIXME + | [] => by simp at *; scalar_tac | hd :: tl => if h: i = 0 then by diff --git a/backends/lean/Base/Primitives/Vec.lean b/backends/lean/Base/Primitives/Vec.lean index be3a0e5b..35092c29 100644 --- a/backends/lean/Base/Primitives/Vec.lean +++ b/backends/lean/Base/Primitives/Vec.lean @@ -16,20 +16,19 @@ open Result Error -- VECTORS -- ------------- -def Vec (α : Type u) := { l : List α // List.length l ≤ Usize.max } +def Vec (α : Type u) := { l : List α // l.length ≤ Usize.max } -- TODO: do we really need it? It should be with Subtype by default -instance Vec.cast (a : Type): Coe (Vec a) (List a) where coe := λ v => v.val +instance Vec.cast (a : Type u): Coe (Vec a) (List a) where coe := λ v => v.val -instance (a : Type) : Arith.HasIntProp (Vec a) where - prop_ty := λ v => v.val.length ≤ Scalar.max ScalarTy.Usize - prop := λ ⟨ _, l ⟩ => l +instance (a : Type u) : Arith.HasIntProp (Vec a) where + prop_ty := λ v => v.val.len ≤ Scalar.max ScalarTy.Usize + prop := λ ⟨ _, l ⟩ => by simp[Scalar.max, List.len_eq_length, *] -example {a: Type} (v : Vec a) : v.val.length ≤ Scalar.max ScalarTy.Usize := by - intro_has_int_prop_instances - simp_all [Scalar.max, Scalar.min] +@[simp] +abbrev Vec.length {α : Type u} (v : Vec α) : Int := v.val.len -example {a: Type} (v : Vec a) : v.val.length ≤ Scalar.max ScalarTy.Usize := by +example {a: Type u} (v : Vec a) : v.length ≤ Scalar.max ScalarTy.Usize := by scalar_tac def Vec.new (α : Type u): Vec α := ⟨ [], by apply Scalar.cMax_suffices .Usize; simp ⟩ @@ -38,9 +37,6 @@ def Vec.len (α : Type u) (v : Vec α) : Usize := let ⟨ v, l ⟩ := v Usize.ofIntCore (List.length v) (by simp [Scalar.min, Usize.min]) l -@[simp] -abbrev Vec.length {α : Type u} (v : Vec α) : Int := v.val.len - -- This shouldn't be used def Vec.push_fwd (α : Type u) (_ : Vec α) (_ : α) : Unit := () @@ -115,11 +111,14 @@ theorem Vec.index_mut_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) : have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) simp only [*] +instance {α : Type u} (p : Vec α → Prop) : Arith.HasIntProp (Subtype p) where + prop_ty := λ x => p x + prop := λ x => x.property + def Vec.index_mut_back (α : Type u) (v: Vec α) (i: Usize) (x: α) : Result (Vec α) := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some _ => - -- TODO: int_tac: introduce the refinements in the context? .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ @[pspec] diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index c0ddc63d..a281f1d2 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -307,7 +307,18 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do let args := (args.get! 2).getArgs (args.get! 3).getArgs.size > 0 trace[Progress] "Split post: {splitPost}" - progressAsmsOrLookupTheorem keep withArg ids splitPost (firstTac [assumptionTac, Arith.scalarTac]) + /- For scalarTac we have a fast track: if the goal is not a linear + arithmetic goal, we skip (note that otherwise, scalarTac would try + to prove a contradiction) -/ + let scalarTac : TacticM Unit := do + if ← Arith.goalIsLinearInt then + -- Also: we don't try to split the goal if it is a conjunction + -- (it shouldn't be) + Arith.scalarTac false + else + throwError "Not a linear arithmetic goal" + progressAsmsOrLookupTheorem keep withArg ids splitPost ( + firstTac [assumptionTac, scalarTac]) elab "progress" args:progressArgs : tactic => evalProgress args -- cgit v1.3.1 From 1854c631a6a7a3f8d45ad18e05547f9d3782c3ee Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 25 Jul 2023 16:26:08 +0200 Subject: Make progress on the hashmap properties --- backends/lean/Base/Arith/Base.lean | 4 ++ backends/lean/Base/Arith/Int.lean | 2 + backends/lean/Base/Arith/Scalar.lean | 3 +- backends/lean/Base/Primitives/Scalar.lean | 48 +++++++++------- backends/lean/Base/Primitives/Vec.lean | 13 ++++- backends/lean/Base/Progress/Base.lean | 4 +- backends/lean/Base/Progress/Progress.lean | 4 +- tests/lean/Hashmap/Properties.lean | 92 +++++++++++++++++++++++++++++++ 8 files changed, 141 insertions(+), 29 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Arith/Base.lean b/backends/lean/Base/Arith/Base.lean index e008f7b9..9c11ed45 100644 --- a/backends/lean/Base/Arith/Base.lean +++ b/backends/lean/Base/Arith/Base.lean @@ -53,4 +53,8 @@ theorem int_pos_ind (p : Int → Prop) : rename_i m cases m <;> simp_all +-- We sometimes need this to make sure no natural numbers appear in the goals +-- TODO: there is probably something more general to do +theorem nat_zero_eq_int_zero : (0 : Nat) = (0 : Int) := by simp + end Arith diff --git a/backends/lean/Base/Arith/Int.lean b/backends/lean/Base/Arith/Int.lean index 3415866e..bc0676d8 100644 --- a/backends/lean/Base/Arith/Int.lean +++ b/backends/lean/Base/Arith/Int.lean @@ -225,6 +225,8 @@ def intTac (splitGoalConjs : Bool) (extraPreprocess : Tactic.TacticM Unit) : Ta -- Preprocess - wondering if we should do this before or after splitting -- the goal. I think before leads to a smaller proof term? Tactic.allGoals (intTacPreprocess extraPreprocess) + -- More preprocessing + Tactic.allGoals (Utils.simpAt [] [``nat_zero_eq_int_zero] [] .wildcard) -- Split the conjunctions in the goal if splitGoalConjs then Tactic.allGoals (Utils.repeatTac Utils.splitConjTarget) -- Call linarith diff --git a/backends/lean/Base/Arith/Scalar.lean b/backends/lean/Base/Arith/Scalar.lean index a56ea08b..6f4a8eba 100644 --- a/backends/lean/Base/Arith/Scalar.lean +++ b/backends/lean/Base/Arith/Scalar.lean @@ -21,7 +21,8 @@ def scalarTacExtraPreprocess : Tactic.TacticM Unit := do ``I8.min, ``I16.min, ``I32.min, ``I64.min, ``I128.min, ``I8.max, ``I16.max, ``I32.max, ``I64.max, ``I128.max, ``U8.min, ``U16.min, ``U32.min, ``U64.min, ``U128.min, - ``U8.max, ``U16.max, ``U32.max, ``U64.max, ``U128.max + ``U8.max, ``U16.max, ``U32.max, ``U64.max, ``U128.max, + ``Usize.min ] [] [] .wildcard elab "scalar_tac_preprocess" : tactic => diff --git a/backends/lean/Base/Primitives/Scalar.lean b/backends/lean/Base/Primitives/Scalar.lean index 1e9b51c2..3beb7527 100644 --- a/backends/lean/Base/Primitives/Scalar.lean +++ b/backends/lean/Base/Primitives/Scalar.lean @@ -66,27 +66,33 @@ def U128.smin : Int := 0 def U128.smax : Int := HPow.hPow 2 128 - 1 -- The "normalized" bounds, that we use in practice -def I8.min := -128 -def I8.max := 127 -def I16.min := -32768 -def I16.max := 32767 -def I32.min := -2147483648 -def I32.max := 2147483647 -def I64.min := -9223372036854775808 -def I64.max := 9223372036854775807 -def I128.min := -170141183460469231731687303715884105728 -def I128.max := 170141183460469231731687303715884105727 -@[simp] def U8.min := 0 -def U8.max := 255 -@[simp] def U16.min := 0 -def U16.max := 65535 -@[simp] def U32.min := 0 -def U32.max := 4294967295 -@[simp] def U64.min := 0 -def U64.max := 18446744073709551615 -@[simp] def U128.min := 0 -def U128.max := 340282366920938463463374607431768211455 -@[simp] def Usize.min := 0 +def I8.min : Int := -128 +def I8.max : Int := 127 +def I16.min : Int := -32768 +def I16.max : Int := 32767 +def I32.min : Int := -2147483648 +def I32.max : Int := 2147483647 +def I64.min : Int := -9223372036854775808 +def I64.max : Int := 9223372036854775807 +def I128.min : Int := -170141183460469231731687303715884105728 +def I128.max : Int := 170141183460469231731687303715884105727 +@[simp] +def U8.min : Int := 0 +def U8.max : Int := 255 +@[simp] +def U16.min : Int := 0 +def U16.max : Int := 65535 +@[simp] +def U32.min : Int := 0 +def U32.max : Int := 4294967295 +@[simp] +def U64.min : Int := 0 +def U64.max : Int := 18446744073709551615 +@[simp] +def U128.min : Int := 0 +def U128.max : Int := 340282366920938463463374607431768211455 +@[simp] +def Usize.min : Int := 0 def Isize.refined_min : { n:Int // n = I32.min ∨ n = I64.min } := ⟨ Isize.smin, by diff --git a/backends/lean/Base/Primitives/Vec.lean b/backends/lean/Base/Primitives/Vec.lean index 35092c29..5a709566 100644 --- a/backends/lean/Base/Primitives/Vec.lean +++ b/backends/lean/Base/Primitives/Vec.lean @@ -22,20 +22,27 @@ def Vec (α : Type u) := { l : List α // l.length ≤ Usize.max } instance Vec.cast (a : Type u): Coe (Vec a) (List a) where coe := λ v => v.val instance (a : Type u) : Arith.HasIntProp (Vec a) where - prop_ty := λ v => v.val.len ≤ Scalar.max ScalarTy.Usize + prop_ty := λ v => 0 ≤ v.val.len ∧ v.val.len ≤ Scalar.max ScalarTy.Usize prop := λ ⟨ _, l ⟩ => by simp[Scalar.max, List.len_eq_length, *] @[simp] abbrev Vec.length {α : Type u} (v : Vec α) : Int := v.val.len +@[simp] +abbrev Vec.v {α : Type u} (v : Vec α) : List α := v.val + example {a: Type u} (v : Vec a) : v.length ≤ Scalar.max ScalarTy.Usize := by scalar_tac def Vec.new (α : Type u): Vec α := ⟨ [], by apply Scalar.cMax_suffices .Usize; simp ⟩ +-- TODO: very annoying that the α is an explicit parameter def Vec.len (α : Type u) (v : Vec α) : Usize := - let ⟨ v, l ⟩ := v - Usize.ofIntCore (List.length v) (by simp [Scalar.min, Usize.min]) l + Usize.ofIntCore v.val.len (by scalar_tac) (by scalar_tac) + +@[simp] +theorem Vec.len_val {α : Type u} (v : Vec α) : (Vec.len α v).val = v.length := + by rfl -- This shouldn't be used def Vec.push_fwd (α : Type u) (_ : Vec α) (_ : α) : Unit := () diff --git a/backends/lean/Base/Progress/Base.lean b/backends/lean/Base/Progress/Base.lean index b54bdf7a..6f820a84 100644 --- a/backends/lean/Base/Progress/Base.lean +++ b/backends/lean/Base/Progress/Base.lean @@ -81,8 +81,8 @@ section Methods let (fExpr, f, args) ← do if mf.isConst ∧ mf.constName = ``Bind.bind then do -- Dive into the bind - let fExpr := margs.get! 4 - fExpr.consumeMData.withApp fun f args => pure (fExpr, f, args) + let fExpr := (margs.get! 4).consumeMData + fExpr.withApp fun f args => pure (fExpr, f, args) else pure (mExpr, mf, margs) trace[Progress] "After stripping the arguments of the function call:\n- f: {f}\n- args: {args}" if ¬ f.isConst then throwError "Not a constant: {f}" diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index a281f1d2..a2c7764f 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -58,9 +58,9 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) let (thBody, _) ← destEq thBody trace[Progress] "After splitting equality: {thBody}" -- There shouldn't be any existential variables in thBody - pure thBody + pure thBody.consumeMData -- Match the body with the target - trace[Progress] "Matching `{thBody}` with `{fExpr}`" + trace[Progress] "Matching:\n- body:\n{thBody}\n- target:\n{fExpr}" let ok ← isDefEq thBody fExpr if ¬ ok then throwError "Could not unify the theorem with the target:\n- theorem: {thBody}\n- target: {fExpr}" let mgoal ← Tactic.getMainGoal diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index de6bf636..b2d5570a 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -136,6 +136,40 @@ def slot_s_inv (l i : Int) (ls : Core.List (Usize × α)) : Prop := def slot_t_inv (l i : Int) (s : List α) : Prop := slot_s_inv l i s.v +-- Interpret the hashmap as a list of lists +def v (hm : HashMap α) : Core.List (Core.List (Usize × α)) := + hm.slots.val.map List.v + +-- Interpret the hashmap as an associative list +def al_v (hm : HashMap α) : Core.List (Usize × α) := + hm.v.flatten + +-- TODO: automatic derivation +instance : Inhabited (List α) where + default := .Nil + +@[simp] +def slots_s_inv (s : Core.List (List α)) : Prop := + ∀ (i : Int), 0 ≤ i → i < s.len → slot_t_inv s.len i (s.index i) + +def slots_t_inv (s : Vec (List α)) : Prop := + slots_s_inv s.v + +@[simp] +def base_inv (hm : HashMap α) : Prop := + -- [num_entries] correctly tracks the number of entries + hm.num_entries.val = hm.al_v.len ∧ + -- Slots invariant + slots_t_inv hm.slots ∧ + -- The capacity must be > 0 (otherwise we can't resize) + 0 < hm.slots.length + -- TODO: load computation + +def inv (hm : HashMap α) : Prop := + -- Base invariant + base_inv hm + -- TODO: either the hashmap is not overloaded, or we can't resize it + theorem insert_in_list_back_spec_aux {α : Type} (l : Int) (key: Usize) (value: α) (l0: List α) (hinv : slot_s_inv_hash l (hash_mod_key key l) l0.v) (hdk : distinct_keys l0.v) : @@ -191,6 +225,64 @@ theorem insert_in_list_back_spec_aux {α : Type} (l : Int) (key: Usize) (value: -- TODO: canonize addition by default? simp_all [Int.add_assoc, Int.add_comm, Int.add_left_comm] +@[pspec] +theorem insert_in_list_back_spec {α : Type} (l : Int) (key: Usize) (value: α) (l0: List α) + (hinv : slot_s_inv_hash l (hash_mod_key key l) l0.v) + (hdk : distinct_keys l0.v) : + ∃ l1, + insert_in_list_back α key value l0 = ret l1 ∧ + -- We update the binding + l1.lookup key = value ∧ + (∀ k, k ≠ key → l1.lookup k = l0.lookup k) ∧ + -- We preserve part of the key invariant + slot_s_inv_hash l (hash_mod_key key l) l1.v ∧ + -- Reasoning about the length + (match l0.lookup key with + | none => l1.len = l0.len + 1 + | some _ => l1.len = l0.len) ∧ + -- The keys are distinct + distinct_keys l1.v + := by + progress with insert_in_list_back_spec_aux as ⟨ l1 .. ⟩ + exists l1 + +def slots_t_lookup (s : Core.List (List α)) (k : Usize) : Option α := + let i := hash_mod_key k s.len + let slot := s.index i + slot.lookup k + +def lookup (hm : HashMap α) (k : Usize) : Option α := + slots_t_lookup hm.slots.val k + +@[simp] +abbrev len_s (hm : HashMap α) : Int := hm.al_v.len + +set_option trace.Progress true +/-set_option pp.explicit true +set_option pp.universes true +set_option pp.notation false-/ + +theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value : α) + (hinv : hm.inv) (hnsat : hm.lookup key = none → hm.len_s < Usize.max) : + ∃ nhm, hm.insert_no_resize α key value = ret nhm ∧ + -- We preserve the invariant + nhm.inv ∧ + -- We updated the binding for key + nhm.lookup key = some value ∧ + -- We left the other bindings unchanged + (∀ k, k ≠ key → nhm.lookup k = hm.lookup k) ∧ + -- Reasoning about the length + (match hm.lookup key with + | none => nhm.len_s = hm.len_s + 1 + | some _ => nhm.len_s = hm.len_s) := by + rw [insert_no_resize] + simp [hash_key] + have : (Vec.len (List α) hm.slots).val ≠ 0 := by + intro + simp_all [inv] + progress as ⟨ hash_mod ⟩ + progress + end HashMap end hashmap -- cgit v1.3.1 From 0cc3c78137434d848188eee2a66b1e2cacfd102e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 25 Jul 2023 19:06:05 +0200 Subject: Make progress on the proofs of the hashmap --- backends/lean/Base/Arith/Int.lean | 1 + backends/lean/Base/IList/IList.lean | 41 +++++++++++ backends/lean/Base/Primitives/Base.lean | 2 +- backends/lean/Base/Primitives/Vec.lean | 20 +++--- backends/lean/Base/Progress/Progress.lean | 34 +++++++-- backends/lean/Base/Utils.lean | 36 +++++++--- tests/lean/Hashmap/Properties.lean | 116 ++++++++++++++++++++++++++++-- 7 files changed, 216 insertions(+), 34 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Arith/Int.lean b/backends/lean/Base/Arith/Int.lean index bc0676d8..48a30a49 100644 --- a/backends/lean/Base/Arith/Int.lean +++ b/backends/lean/Base/Arith/Int.lean @@ -43,6 +43,7 @@ instance (x y : Int) : IsLinearIntProp (x > y) where instance (x y : Int) : IsLinearIntProp (x ≤ y) where instance (x y : Int) : IsLinearIntProp (x ≥ y) where instance (x y : Int) : IsLinearIntProp (x ≥ y) where +instance (x y : Int) : IsLinearIntProp (x = y) where /- It seems we don't need to do any special preprocessing when the *goal* has the following shape - I guess `linarith` automatically calls `intro` -/ instance (x y : Int) : IsLinearIntProp (¬ x = y) where diff --git a/backends/lean/Base/IList/IList.lean b/backends/lean/Base/IList/IList.lean index 2443b1a6..93047a1b 100644 --- a/backends/lean/Base/IList/IList.lean +++ b/backends/lean/Base/IList/IList.lean @@ -123,6 +123,10 @@ theorem length_update (ls : List α) (i : Int) (x : α) : (ls.update i x).length theorem len_update (ls : List α) (i : Int) (x : α) : (ls.update i x).len = ls.len := by simp [len_eq_length] +@[simp] +theorem len_map (ls : List α) (f : α → β) : (ls.map f).len = ls.len := by + simp [len_eq_length] + theorem left_length_eq_append_eq (l1 l2 l1' l2' : List α) (heq : l1.length = l1'.length) : l1 ++ l2 = l1' ++ l2' ↔ l1 = l1' ∧ l2 = l2' := by revert l1' @@ -210,6 +214,43 @@ theorem index_eq simp at * apply index_eq <;> scalar_tac +theorem update_map_eq {α : Type u} {β : Type v} (ls : List α) (i : Int) (x : α) (f : α → β) : + (ls.update i x).map f = (ls.map f).update i (f x) := + match ls with + | [] => by simp + | hd :: tl => + if h : i = 0 then by simp [*] + else + have hi := update_map_eq tl (i - 1) x f + by simp [*] + +theorem len_flatten_update_eq {α : Type u} (ls : List (List α)) (i : Int) (x : List α) + (h0 : 0 ≤ i) (h1 : i < ls.len) : + (ls.update i x).flatten.len = ls.flatten.len + x.len - (ls.index i).len := + match ls with + | [] => by simp at h1; int_tac + | hd :: tl => by + simp at h1 + if h : i = 0 then simp [*]; int_tac + else + have hi := len_flatten_update_eq tl (i - 1) x (by int_tac) (by int_tac) + simp [*] + int_tac + +@[simp] +theorem index_map_eq {α : Type u} {β : Type v} [Inhabited α] [Inhabited β] (ls : List α) (i : Int) (f : α → β) + (h0 : 0 ≤ i) (h1 : i < ls.len) : + (ls.map f).index i = f (ls.index i) := + match ls with + | [] => by simp at h1; int_tac + | hd :: tl => + if h : i = 0 then by + simp [*] + else + have hi := index_map_eq tl (i - 1) f (by int_tac) (by simp at h1; int_tac) + by + simp [*] + def allP {α : Type u} (l : List α) (p: α → Prop) : Prop := foldr (fun a r => p a ∧ r) True l diff --git a/backends/lean/Base/Primitives/Base.lean b/backends/lean/Base/Primitives/Base.lean index db462c38..7c0fa3bb 100644 --- a/backends/lean/Base/Primitives/Base.lean +++ b/backends/lean/Base/Primitives/Base.lean @@ -76,7 +76,7 @@ def eval_global {α: Type u} (x: Result α) (_: ret? x): α := /- DO-DSL SUPPORT -/ -def bind {α : Type u} {β : Type v} (x: Result α) (f: α -> Result β) : Result β := +def bind {α : Type u} {β : Type v} (x: Result α) (f: α → Result β) : Result β := match x with | ret v => f v | fail v => fail v diff --git a/backends/lean/Base/Primitives/Vec.lean b/backends/lean/Base/Primitives/Vec.lean index 5a709566..523372bb 100644 --- a/backends/lean/Base/Primitives/Vec.lean +++ b/backends/lean/Base/Primitives/Vec.lean @@ -75,10 +75,9 @@ def Vec.insert (α : Type u) (v: Vec α) (i: Usize) (x: α) : Result (Vec α) := .fail arrayOutOfBounds @[pspec] -theorem Vec.insert_spec {α : Type u} (v: Vec α) (i: Usize) (x: α) : - i.val < v.length → +theorem Vec.insert_spec {α : Type u} (v: Vec α) (i: Usize) (x: α) + (hbound : i.val < v.length) : ∃ nv, v.insert α i x = ret nv ∧ nv.val = v.val.update i.val x := by - intro h simp [insert, *] def Vec.index (α : Type u) (v: Vec α) (i: Usize) : Result α := @@ -87,10 +86,9 @@ def Vec.index (α : Type u) (v: Vec α) (i: Usize) : Result α := | some x => ret x @[pspec] -theorem Vec.index_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) : - i.val < v.length → +theorem Vec.index_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) + (hbound : i.val < v.length) : v.index α i = ret (v.val.index i.val) := by - intro simp only [index] -- TODO: dependent rewrite have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) @@ -109,10 +107,9 @@ def Vec.index_mut (α : Type u) (v: Vec α) (i: Usize) : Result α := | some x => ret x @[pspec] -theorem Vec.index_mut_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) : - i.val < v.length → +theorem Vec.index_mut_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) + (hbound : i.val < v.length) : v.index_mut α i = ret (v.val.index i.val) := by - intro simp only [index_mut] -- TODO: dependent rewrite have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) @@ -129,12 +126,11 @@ def Vec.index_mut_back (α : Type u) (v: Vec α) (i: Usize) (x: α) : Result (Ve .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ @[pspec] -theorem Vec.index_mut_back_spec {α : Type u} (v: Vec α) (i: Usize) (x : α) : - i.val < v.length → +theorem Vec.index_mut_back_spec {α : Type u} (v: Vec α) (i: Usize) (x : α) + (hbound : i.val < v.length) : ∃ nv, v.index_mut_back α i x = ret nv ∧ nv.val = v.val.update i.val x := by - intro simp only [index_mut_back] have h := List.indexOpt_bounds v.val i.val split diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index a2c7764f..4a406bdf 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -1,6 +1,7 @@ import Lean import Base.Arith import Base.Progress.Base +import Base.Primitives -- TODO: remove? namespace Progress @@ -41,7 +42,12 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) match th with | .Theorem thName => let thDecl := env.constants.find! thName - pure thDecl.type + -- We have to introduce fresh meta-variables for the universes already + let ul : List (Name × Level) ← + thDecl.levelParams.mapM (λ x => do pure (x, ← mkFreshLevelMVar)) + let ulMap : HashMap Name Level := HashMap.ofList ul + let thTy := thDecl.type.instantiateLevelParamsCore (λ x => ulMap.find! x) + pure thTy | .Local asmDecl => pure asmDecl.type trace[Progress] "Looked up theorem/assumption type: {thTy}" -- TODO: the tactic fails if we uncomment withNewMCtxDepth @@ -129,15 +135,16 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) Split the remaining conjunctions by using fresh ids if the user instructed to fully split the post-condition, otherwise stop -/ if splitPost then - splitFullConjTac hPost (λ _ => pure .Ok) + splitFullConjTac true hPost (λ _ => pure .Ok) else pure .Ok | nid :: ids => do - trace[Progress] "Splitting post: {hPost}" + trace[Progress] "Splitting post: {← inferType hPost}" -- Split let nid ← do match nid with | none => mkFreshUserName `h | some nid => pure nid + trace[Progress] "\n- prevId: {prevId}\n- nid: {nid}\n- remaining ids: {ids}" if ← isConj (← inferType hPost) then splitConjTac hPost (some (prevId, nid)) (λ _ nhPost => splitPostWithIds nid nhPost ids) else return (.Error m!"Too many ids provided ({ids0}) not enough conjuncts to split in the postcondition") @@ -323,7 +330,7 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do elab "progress" args:progressArgs : tactic => evalProgress args -/- namespace Test +namespace Test open Primitives Result set_option trace.Progress true @@ -336,10 +343,25 @@ elab "progress" args:progressArgs : tactic => (hmin : Scalar.min ty ≤ x.val + y.val) (hmax : x.val + y.val ≤ Scalar.max ty) : ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by --- progress keep as h with Scalar.add_spec as ⟨ z ⟩ progress keep as h as ⟨ x, h1 .. ⟩ simp [*] -end Test -/ + example {ty} {x y : Scalar ty} + (hmin : Scalar.min ty ≤ x.val + y.val) + (hmax : x.val + y.val ≤ Scalar.max ty) : + ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by + progress keep as h with Scalar.add_spec as ⟨ z ⟩ + simp [*] + + /- 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 : α) + (hbounds : i.val < v.length) : + ∃ nv, v.index_mut_back α i x = ret nv ∧ + nv.val = v.val.update i.val x := by + progress + simp [*] + +end Test end Progress diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index 66497a49..f6dc45c7 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -1,6 +1,7 @@ import Lean import Mathlib.Tactic.Core import Mathlib.Tactic.LeftRight +import Base.UtilsBase /- Mathlib tactics: @@ -331,13 +332,13 @@ def assumptionTac : TacticM Unit := liftMetaTactic fun mvarId => do mvarId.assumption; pure [] def isConj (e : Expr) : MetaM Bool := - e.withApp fun f args => pure (f.isConstOf ``And ∧ args.size = 2) + e.consumeMData.withApp fun f args => pure (f.isConstOf ``And ∧ args.size = 2) -- Return the first conjunct if the expression is a conjunction, or the -- expression itself otherwise. Also return the second conjunct if it is a -- conjunction. def optSplitConj (e : Expr) : MetaM (Expr × Option Expr) := do - e.withApp fun f args => + e.consumeMData.withApp fun f args => if f.isConstOf ``And ∧ args.size = 2 then pure (args.get! 0, some (args.get! 1)) else pure (e, none) @@ -345,6 +346,7 @@ def optSplitConj (e : Expr) : MetaM (Expr × Option Expr) := do def splitConjTarget : TacticM Unit := do withMainContext do let g ← getMainTarget + trace[Utils] "splitConjTarget: goal: {g}" -- The tactic was initially implemened with `_root_.Lean.MVarId.apply` -- but it tended to mess the goal by unfolding terms, even when it failed let (l, r) ← optSplitConj g @@ -525,18 +527,26 @@ def splitConjTac (h : Expr) (optIds : Option (Name × Name)) (k : Expr → Expr throwError "Not a conjunction" -- Tactic to fully split a conjunction -partial def splitFullConjTacAux [Inhabited α] [Nonempty α] (l : List Expr) (h : Expr) (k : List Expr → TacticM α) : TacticM α := do +partial def splitFullConjTacAux [Inhabited α] [Nonempty α] (keepCurrentName : Bool) (l : List Expr) (h : Expr) (k : List Expr → TacticM α) : TacticM α := do try - splitConjTac h none (λ h1 h2 => - splitFullConjTacAux l h1 (λ l1 => - splitFullConjTacAux l1 h2 (λ l2 => + let ids ← do + if keepCurrentName then do + let cur := (← h.fvarId!.getDecl).userName + let nid ← mkFreshUserName `h + pure (some (cur, nid)) + else + pure none + splitConjTac h ids (λ h1 h2 => + splitFullConjTacAux keepCurrentName l h1 (λ l1 => + splitFullConjTacAux keepCurrentName l1 h2 (λ l2 => k l2))) catch _ => k (h :: l) -- Tactic to fully split a conjunction -def splitFullConjTac [Inhabited α] [Nonempty α] (h : Expr) (k : List Expr → TacticM α) : TacticM α := do - splitFullConjTacAux [] h (λ l => k l.reverse) +-- `keepCurrentName`: if `true`, then the first conjunct has the name of the original assumption +def splitFullConjTac [Inhabited α] [Nonempty α] (keepCurrentName : Bool) (h : Expr) (k : List Expr → TacticM α) : TacticM α := do + splitFullConjTacAux keepCurrentName [] h (λ l => k l.reverse) syntax optAtArgs := ("at" ident)? def elabOptAtArgs (args : TSyntax `Utils.optAtArgs) : TacticM (Option Expr) := do @@ -553,17 +563,21 @@ def elabOptAtArgs (args : TSyntax `Utils.optAtArgs) : TacticM (Option Expr) := d elab "split_conj" args:optAtArgs : tactic => do withMainContext do match ← elabOptAtArgs args with - | some fvar => + | some fvar => do + trace[Utils] "split at {fvar}" splitConjTac fvar none (fun _ _ => pure ()) - | none => + | none => do + trace[Utils] "split goal" splitConjTarget elab "split_conjs" args:optAtArgs : tactic => do withMainContext do match ← elabOptAtArgs args with | some fvar => - splitFullConjTac fvar (fun _ => pure ()) + trace[Utils] "split at {fvar}" + splitFullConjTac false fvar (fun _ => pure ()) | none => + trace[Utils] "split goal" repeatTac splitConjTarget elab "split_existsl" " at " n:ident : tactic => do diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index b2d5570a..92285c0d 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -55,6 +55,7 @@ theorem match_lawful_beq [BEq α] [LawfulBEq α] [DecidableEq α] (x y : α) : (x == y) = (if x = y then true else false) := by split <;> simp_all +@[pspec] theorem insert_in_list_spec0 {α : Type} (key: Usize) (value: α) (ls: List α) : ∃ b, insert_in_list α key value ls = ret b ∧ @@ -126,6 +127,10 @@ def hash_mod_key (k : Usize) (l : Int) : Int := | .ret k => k.val % l | _ => 0 +@[simp] +theorem hash_mod_key_eq : hash_mod_key k l = k.val % l := by + simp [hash_mod_key, hash_key] + def slot_s_inv_hash (l i : Int) (ls : Core.List (Usize × α)) : Prop := ls.allP (λ (k, _) => hash_mod_key k l = i) @@ -246,6 +251,7 @@ theorem insert_in_list_back_spec {α : Type} (l : Int) (key: Usize) (value: α) progress with insert_in_list_back_spec_aux as ⟨ l1 .. ⟩ exists l1 +@[simp] def slots_t_lookup (s : Core.List (List α)) (k : Usize) : Option α := let i := hash_mod_key k s.len let slot := s.index i @@ -260,7 +266,15 @@ abbrev len_s (hm : HashMap α) : Int := hm.al_v.len set_option trace.Progress true /-set_option pp.explicit true set_option pp.universes true -set_option pp.notation false-/ +set_option pp.notation false -/ + +-- Remark: α and β must live in the same universe, otherwise the +-- bind doesn't work +theorem if_update_eq + {α β : Type u} (b : Bool) (y : α) (e : Result α) (f : α → Result β) : + (if b then Bind.bind e f else f y) = Bind.bind (if b then e else pure y) f + := by + split <;> simp [Pure.pure] theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value : α) (hinv : hm.inv) (hnsat : hm.lookup key = none → hm.len_s < Usize.max) : @@ -270,18 +284,112 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value -- We updated the binding for key nhm.lookup key = some value ∧ -- We left the other bindings unchanged - (∀ k, k ≠ key → nhm.lookup k = hm.lookup k) ∧ + (∀ k, ¬ k = key → nhm.lookup k = hm.lookup k) ∧ -- Reasoning about the length (match hm.lookup key with | none => nhm.len_s = hm.len_s + 1 | some _ => nhm.len_s = hm.len_s) := by rw [insert_no_resize] simp [hash_key] - have : (Vec.len (List α) hm.slots).val ≠ 0 := by + have _ : (Vec.len (List α) hm.slots).val ≠ 0 := by checkpoint intro simp_all [inv] - progress as ⟨ hash_mod ⟩ + -- TODO: progress keep as ⟨ ... ⟩ : conflict + progress keep as h as ⟨ hash_mod, hhm ⟩ + have _ : 0 ≤ hash_mod.val := by checkpoint scalar_tac + have _ : hash_mod.val < Vec.length hm.slots := by sorry + -- have h := Primitives.Vec.index_mut_spec hm.slots hash_mod + -- TODO: change the spec of Vec.index_mut to introduce a let-binding. + -- or: make progress introduce the let-binding by itself (this is clearer) progress + -- TODO: make progress use the names written in the goal + progress as ⟨ inserted ⟩ + rw [if_update_eq] -- TODO: necessary because we don't have a join + -- TODO: progress to ... + have hipost : + ∃ i0, (if inserted = true then hm.num_entries + Usize.ofInt 1 else pure hm.num_entries) = ret i0 ∧ + i0.val = if inserted then hm.num_entries.val + 1 else hm.num_entries.val + := by sorry + progress as ⟨ i0 ⟩ + -- TODO: progress "eager" to match premises with assumptions while instantiating + -- meta-variables + have h_slot : slot_s_inv_hash hm.slots.length hash_mod.val (hm.slots.v.index hash_mod.val).v := by sorry + have hd : distinct_keys (hm.slots.v.index hash_mod.val).v := by checkpoint + simp [inv, slots_t_inv, slot_t_inv] at hinv + have h := hinv.right.left hash_mod.val (by assumption) (by assumption) + simp [h] + -- TODO: hide the variables and only keep the props + -- TODO: allow providing terms to progress to instantiate the meta variables + -- which are not propositions + progress as ⟨ l0, _, _, _, hlen .. ⟩ + . checkpoint exact hm.slots.length + . checkpoint simp_all + . -- Finishing the proof + progress as ⟨ v ⟩ + -- TODO: update progress to automate that + let nhm : HashMap α := { num_entries := i0, max_load_factor := hm.max_load_factor, max_load := hm.max_load, slots := v } + exists nhm + have hupdt : lookup nhm key = some value := by checkpoint + simp [lookup, List.lookup] at * + simp_all + have hlkp : ∀ k, ¬ k = key → nhm.lookup k = hm.lookup k := by checkpoint + simp [lookup, List.lookup] at * + intro k hk + -- We have to make a case disjunction: either the hashes are different, + -- in which case we don't even lookup the same slots, or the hashes + -- are the same, in which case we have to reason about what happens + -- in one slot + let k_hash_mod := k.val % v.val.len + have _ : 0 ≤ k_hash_mod := by sorry + have _ : k_hash_mod < Vec.length hm.slots := by sorry + if h_hm : k_hash_mod = hash_mod.val then + simp_all + else + simp_all + have _ : + match hm.lookup key with + | none => nhm.len_s = hm.len_s + 1 + | some _ => nhm.len_s = hm.len_s := by checkpoint + simp only [lookup, List.lookup, len_s, al_v, HashMap.v, slots_t_lookup] at * + -- We have to do a case disjunction + simp_all + simp [_root_.List.update_map_eq] + -- TODO: dependent rewrites + have _ : key.val % hm.slots.val.len < (List.map List.v hm.slots.val).len := by + simp [*] + simp [_root_.List.len_flatten_update_eq, *] + split <;> + rename_i heq <;> + simp [heq] at hlen <;> + -- TODO: canonize addition by default? We need a tactic to simplify arithmetic equalities + -- with addition and substractions ((ℤ, +) is a ring or something - there should exist a tactic + -- somewhere in mathlib?) + simp [Int.add_assoc, Int.add_comm, Int.add_left_comm] <;> + int_tac + have hinv : inv nhm := by + simp [inv] at * + split_conjs + . match h: lookup hm key with + | none => + simp [h, lookup] at * + simp_all + | some _ => + simp_all [lookup] + . simp [slots_t_inv, slot_t_inv] at * + intro i hipos _ + have hs := hinv.right.left i hipos (by simp_all) + -- We need a case disjunction + if i = key.val % _root_.List.len hm.slots.val then + simp_all + else + simp_all + . match h: lookup hm key with + | none => + simp [h] at * + simp [*] + | some _ => + simp_all + simp_all end HashMap -- cgit v1.3.1 From 81e991822879a942af34489b7a072f31739f28f6 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 26 Jul 2023 12:37:17 +0200 Subject: Update the syntax of the progress tactic --- backends/lean/Base/Arith/Int.lean | 2 +- backends/lean/Base/Arith/Scalar.lean | 2 +- backends/lean/Base/Progress/Progress.lean | 41 +++---- backends/lean/Base/Utils.lean | 12 ++- tests/lean/Hashmap/Properties.lean | 171 +++++++++++++++--------------- 5 files changed, 117 insertions(+), 111 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Arith/Int.lean b/backends/lean/Base/Arith/Int.lean index 48a30a49..7a5bbe98 100644 --- a/backends/lean/Base/Arith/Int.lean +++ b/backends/lean/Base/Arith/Int.lean @@ -147,7 +147,7 @@ def introInstances (declToUnfold : Name) (lookup : Expr → MetaM (Option Expr)) let hs ← collectInstancesFromMainCtx lookup hs.toArray.mapM fun e => do let type ← inferType e - let name ← mkFreshUserName `h + let name ← mkFreshAnonPropUserName -- Add a declaration let nval ← Utils.addDeclTac name e type (asLet := false) -- Simplify to unfold the declaration to unfold (i.e., the projector) diff --git a/backends/lean/Base/Arith/Scalar.lean b/backends/lean/Base/Arith/Scalar.lean index 6f4a8eba..b792ff21 100644 --- a/backends/lean/Base/Arith/Scalar.lean +++ b/backends/lean/Base/Arith/Scalar.lean @@ -12,7 +12,7 @@ def scalarTacExtraPreprocess : Tactic.TacticM Unit := do -- Inroduce the bounds for the isize/usize types let add (e : Expr) : Tactic.TacticM Unit := do let ty ← inferType e - let _ ← Utils.addDeclTac (← mkFreshUserName `h) e ty (asLet := false) + let _ ← Utils.addDeclTac (← Utils.mkFreshAnonPropUserName) e ty (asLet := false) add (← mkAppM ``Scalar.cMin_bound #[.const ``ScalarTy.Isize []]) add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Usize []]) add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Isize []]) diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 4a406bdf..9300edff 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -79,7 +79,7 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) match th with | .Theorem thName => mkAppOptM thName (mvars.map some) | .Local decl => mkAppOptM' (mkFVar decl.fvarId) (mvars.map some) - let asmName ← do match keep with | none => mkFreshUserName `h | some n => do pure n + let asmName ← do match keep with | none => mkFreshAnonPropUserName | some n => do pure n let thTy ← inferType th let thAsm ← Utils.addDeclTac asmName th thTy (asLet := false) withMainContext do -- The context changed - TODO: remove once addDeclTac is updated @@ -101,8 +101,8 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) let hName := (← h.fvarId!.getDecl).userName let (optIds, ids) ← do match ids with - | [] => do pure (some (hName, ← mkFreshUserName `h), []) - | none :: ids => do pure (some (hName, ← mkFreshUserName `h), ids) + | [] => do pure (some (hName, ← mkFreshAnonPropUserName), []) + | none :: ids => do pure (some (hName, ← mkFreshAnonPropUserName), ids) | some id :: ids => do pure (some (hName, id), ids) splitConjTac h optIds (fun hEq hPost => k hEq (some hPost) ids) else k h none ids @@ -142,7 +142,7 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) -- Split let nid ← do match nid with - | none => mkFreshUserName `h + | none => mkFreshAnonPropUserName | some nid => pure nid trace[Progress] "\n- prevId: {prevId}\n- nid: {nid}\n- remaining ids: {ids}" if ← isConj (← inferType hPost) then @@ -270,23 +270,26 @@ def progressAsmsOrLookupTheorem (keep : Option Name) (withTh : Option TheoremOrL -- Nothing worked: failed throwError "Progress failed" -syntax progressArgs := ("keep" ("as" (ident))?)? ("with" ident)? ("as" " ⟨ " (ident <|> "_"),* " .."? " ⟩")? +syntax progressArgs := ("keep" (ident <|> "_"))? ("with" ident)? ("as" " ⟨ " (ident <|> "_"),* " .."? " ⟩")? def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do let args := args.raw -- Process the arguments to retrieve the identifiers to use trace[Progress] "Progress arguments: {args}" - let args := args.getArgs + let (keepArg, withArg, asArgs) ← + match args.getArgs.toList with + | [keepArg, withArg, asArgs] => do pure (keepArg, withArg, asArgs) + | _ => throwError "Unexpected: invalid arguments" let keep : Option Name ← do - let args := (args.get! 0).getArgs - if args.size > 0 then do - let args := (args.get! 1).getArgs - if args.size > 0 then pure (some (args.get! 1).getId) - else do pure (some (← mkFreshUserName `h)) - else pure none + let args := keepArg.getArgs + trace[Progress] "Keep args: {args}" + let arg := args.get! 1 + trace[Progress] "Keep arg: {arg}" + if arg.isIdent then pure (some arg.getId) + else do pure (some (← mkFreshAnonPropUserName)) trace[Progress] "Keep: {keep}" let withArg ← do - let withArg := (args.get! 1).getArgs + let withArg := withArg.getArgs if withArg.size > 0 then let id := withArg.get! 1 trace[Progress] "With arg: {id}" @@ -306,12 +309,12 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do pure (some (.Theorem id)) else pure none let ids := - let args := (args.get! 2).getArgs + let args := asArgs.getArgs let args := (args.get! 2).getSepArgs args.map (λ s => if s.isIdent then some s.getId else none) trace[Progress] "User-provided ids: {ids}" let splitPost : Bool := - let args := (args.get! 2).getArgs + let args := asArgs.getArgs (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 @@ -343,15 +346,15 @@ namespace Test (hmin : Scalar.min ty ≤ x.val + y.val) (hmax : x.val + y.val ≤ Scalar.max ty) : ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by - progress keep as h as ⟨ x, h1 .. ⟩ - simp [*] + progress keep _ as ⟨ z, h1 .. ⟩ + simp [*, h1] example {ty} {x y : Scalar ty} (hmin : Scalar.min ty ≤ x.val + y.val) (hmax : x.val + y.val ≤ Scalar.max ty) : ∃ z, x + y = ret z ∧ z.val = x.val + y.val := by - progress keep as h with Scalar.add_spec as ⟨ z ⟩ - simp [*] + progress keep h with Scalar.add_spec as ⟨ z ⟩ + simp [*, h] /- Checking that universe instantiation works: the original spec uses `α : Type u` where u is quantified, while here we use `α : Type 0` -/ diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index f6dc45c7..1f8f1455 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -201,6 +201,10 @@ partial def mapVisit (k : Nat → Expr → MetaM Expr) (e : Expr) : MetaM Expr : | .proj _ _ b => return e.updateProj! (← visit (i + 1) b) visit 0 e +-- Generate a fresh user name for an anonymous proposition to introduce in the +-- assumptions +def mkFreshAnonPropUserName := mkFreshUserName `_ + section Methods variable [MonadLiftT MetaM m] [MonadControlT MetaM m] [Monad m] [MonadError m] variable {a : Type} @@ -411,7 +415,7 @@ def splitDisjTac (h : Expr) (kleft kright : TacticM Unit) : TacticM Unit := do trace[Arith] "left: {inl}: {mleft}" trace[Arith] "right: {inr}: {mright}" -- Create the match expression - withLocalDeclD (← mkFreshUserName `h) hTy fun hVar => do + withLocalDeclD (← mkFreshAnonPropUserName) hTy fun hVar => do let motive ← mkLambdaFVars #[hVar] goalType let casesExpr ← mkAppOptM ``Or.casesOn #[a, b, motive, h, inl, inr] let mgoal ← getMainGoal @@ -505,8 +509,8 @@ def splitConjTac (h : Expr) (optIds : Option (Name × Name)) (k : Expr → Expr let altVarNames ← match optIds with | none => do - let id0 ← mkFreshUserName `h - let id1 ← mkFreshUserName `h + let id0 ← mkFreshAnonPropUserName + let id1 ← mkFreshAnonPropUserName pure #[{ varNames := [id0, id1] }] | some (id0, id1) => do pure #[{ varNames := [id0, id1] }] @@ -532,7 +536,7 @@ partial def splitFullConjTacAux [Inhabited α] [Nonempty α] (keepCurrentName : let ids ← do if keepCurrentName then do let cur := (← h.fvarId!.getDecl).userName - let nid ← mkFreshUserName `h + let nid ← mkFreshAnonPropUserName pure (some (cur, nid)) else pure none diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index 208875a6..96b8193d 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -95,7 +95,7 @@ theorem insert_in_list_spec1 {α : Type} (key: Usize) (value: α) (ls: List α) simp only [insert_in_list] rw [insert_in_list_loop] conv => rhs; ext; simp [*] - progress keep as heq as ⟨ b, hi ⟩ + progress keep heq as ⟨ b, hi ⟩ simp only [insert_in_list] at heq exists b @@ -219,7 +219,7 @@ theorem insert_in_list_back_spec_aux {α : Type} (l : Int) (key: Usize) (value: have : distinct_keys (List.v tl0) := by checkpoint simp [distinct_keys] at hdk simp [hdk, distinct_keys] - progress keep as heq as ⟨ tl1 .. ⟩ + progress keep heq as ⟨ tl1 .. ⟩ simp only [insert_in_list_back] at heq have : slot_s_inv_hash l (hash_mod_key key l) (List.v (List.Cons k v tl1)) := by checkpoint simp [List.v, slot_s_inv_hash] at * @@ -289,8 +289,7 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value have _ : (Vec.len (List α) hm.slots).val ≠ 0 := by checkpoint intro simp_all [inv] - -- TODO: progress keep as ⟨ ... ⟩ : conflict - progress keep as h as ⟨ hash_mod, hhm ⟩ + progress keep _ as ⟨ hash_mod, hhm ⟩ have _ : 0 ≤ hash_mod.val := by checkpoint scalar_tac have _ : hash_mod.val < Vec.length hm.slots := by have : 0 < hm.slots.val.len := by @@ -324,11 +323,12 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value progress as ⟨ i0 ⟩ -- TODO: progress "eager" to match premises with assumptions while instantiating -- meta-variables - have h_slot : slot_s_inv_hash hm.slots.length hash_mod.val (hm.slots.v.index hash_mod.val).v := by + have h_slot : slot_s_inv_hash hm.slots.length (hash_mod_key key hm.slots.length) + (List.v (List.index (hm.slots.val) hash_mod.val)) := by simp [inv] at hinv - have h := hinv.right.left hash_mod.val (by assumption) (by assumption) - simp [slot_t_inv] at h - simp [h] + have h := (hinv.right.left hash_mod.val (by assumption) (by assumption)).right + simp [slot_t_inv, hhm] at h + simp [h, hhm] have hd : distinct_keys (hm.slots.v.index hash_mod.val).v := by checkpoint simp [inv, slots_t_inv, slot_t_inv] at hinv have h := hinv.right.left hash_mod.val (by assumption) (by assumption) @@ -337,88 +337,87 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value -- TODO: allow providing terms to progress to instantiate the meta variables -- which are not propositions progress as ⟨ l0, _, _, _, hlen .. ⟩ - . checkpoint exact hm.slots.length - . checkpoint simp_all - . -- Finishing the proof - progress keep as hv as ⟨ v, h_veq ⟩ - -- TODO: update progress to automate that - let nhm : HashMap α := { num_entries := i0, max_load_factor := hm.max_load_factor, max_load := hm.max_load, slots := v } - exists nhm - -- TODO: later I don't want to inline nhm - we need to control simp - have hupdt : lookup nhm key = some value := by checkpoint - simp [lookup, List.lookup] at * + -- Finishing the proof + progress keep hv as ⟨ v, h_veq ⟩ + -- TODO: update progress to automate that + let nhm : HashMap α := { num_entries := i0, max_load_factor := hm.max_load_factor, max_load := hm.max_load, slots := v } + exists nhm + -- TODO: later I don't want to inline nhm - we need to control simp + have hupdt : lookup nhm key = some value := by checkpoint + simp [lookup, List.lookup] at * + simp_all + have hlkp : ∀ k, ¬ k = key → nhm.lookup k = hm.lookup k := by + simp [lookup, List.lookup] at * + intro k hk + -- We have to make a case disjunction: either the hashes are different, + -- in which case we don't even lookup the same slots, or the hashes + -- are the same, in which case we have to reason about what happens + -- in one slot + let k_hash_mod := k.val % v.val.len + have : 0 < hm.slots.val.len := by simp_all [inv] + have hvpos : 0 < v.val.len := by simp_all + have hvnz: v.val.len ≠ 0 := by simp_all - have hlkp : ∀ k, ¬ k = key → nhm.lookup k = hm.lookup k := by - simp [lookup, List.lookup] at * - intro k hk - -- We have to make a case disjunction: either the hashes are different, - -- in which case we don't even lookup the same slots, or the hashes - -- are the same, in which case we have to reason about what happens - -- in one slot - let k_hash_mod := k.val % v.val.len - have : 0 < hm.slots.val.len := by simp_all [inv] - have hvpos : 0 < v.val.len := by simp_all - have hvnz: v.val.len ≠ 0 := by - simp_all - have _ : 0 ≤ k_hash_mod := by - -- TODO: we want to automate this - simp - apply Int.emod_nonneg k.val hvnz - have _ : k_hash_mod < Vec.length hm.slots := by - -- TODO: we want to automate this - simp - have h := Int.emod_lt_of_pos k.val hvpos - simp_all - if h_hm : k_hash_mod = hash_mod.val then + have _ : 0 ≤ k_hash_mod := by + -- TODO: we want to automate this + simp + apply Int.emod_nonneg k.val hvnz + have _ : k_hash_mod < Vec.length hm.slots := by + -- TODO: we want to automate this + simp + have h := Int.emod_lt_of_pos k.val hvpos + simp_all + if h_hm : k_hash_mod = hash_mod.val then + simp_all + else + simp_all + have _ : + match hm.lookup key with + | none => nhm.len_s = hm.len_s + 1 + | some _ => nhm.len_s = hm.len_s := by checkpoint + simp only [lookup, List.lookup, len_s, al_v, HashMap.v, slots_t_lookup] at * + -- We have to do a case disjunction + simp_all + simp [_root_.List.update_map_eq] + -- TODO: dependent rewrites + have _ : key.val % hm.slots.val.len < (List.map List.v hm.slots.val).len := by + simp [*] + simp [_root_.List.len_flatten_update_eq, *] + split <;> + rename_i heq <;> + simp [heq] at hlen <;> + -- TODO: canonize addition by default? We need a tactic to simplify arithmetic equalities + -- with addition and substractions ((ℤ, +) is a ring or something - there should exist a tactic + -- somewhere in mathlib?) + simp [Int.add_assoc, Int.add_comm, Int.add_left_comm] <;> + int_tac + have hinv : inv nhm := by + simp [inv] at * + split_conjs + . match h: lookup hm key with + | none => + simp [h, lookup] at * simp_all + | some _ => + simp_all [lookup] + . simp [slots_t_inv, slot_t_inv] at * + intro i hipos _ + have _ := hinv.right.left i hipos (by simp_all) + simp [hhm, h_veq] at * -- TODO: annoying + -- We need a case disjunction + if h_ieq : i = key.val % _root_.List.len hm.slots.val then + -- TODO: simp_all fails: "(deterministic) timeout at 'whnf'" + -- Also, it is annoying to do this kind + -- of rewritings by hand. We could have a different simp + -- which safely substitutes variables when we have an + -- equality `x = ...` and `x` doesn't appear in the rhs + simp [h_ieq] at * + simp [*] else - simp_all - have _ : - match hm.lookup key with - | none => nhm.len_s = hm.len_s + 1 - | some _ => nhm.len_s = hm.len_s := by checkpoint - simp only [lookup, List.lookup, len_s, al_v, HashMap.v, slots_t_lookup] at * - -- We have to do a case disjunction - simp_all - simp [_root_.List.update_map_eq] - -- TODO: dependent rewrites - have _ : key.val % hm.slots.val.len < (List.map List.v hm.slots.val).len := by simp [*] - simp [_root_.List.len_flatten_update_eq, *] - split <;> - rename_i heq <;> - simp [heq] at hlen <;> - -- TODO: canonize addition by default? We need a tactic to simplify arithmetic equalities - -- with addition and substractions ((ℤ, +) is a ring or something - there should exist a tactic - -- somewhere in mathlib?) - simp [Int.add_assoc, Int.add_comm, Int.add_left_comm] <;> - int_tac - have hinv : inv nhm := by - simp [inv] at * - split_conjs - . match h: lookup hm key with - | none => - simp [h, lookup] at * - simp_all - | some _ => - simp_all [lookup] - . simp [slots_t_inv, slot_t_inv] at * - intro i hipos _ - have _ := hinv.right.left i hipos (by simp_all) - simp [hhm, h_veq] at * -- TODO: annoying - -- We need a case disjunction - if h_ieq : i = key.val % _root_.List.len hm.slots.val then - -- TODO: simp_all loops (investigate). - -- Also, it is annoying to do this kind - -- of rewritings by hand. We could have a different simp - -- which safely substitutes variables when we have an - -- equality `x = ...` and `x` doesn't appear in the rhs - simp [h_ieq] at * - simp [*] - else - simp [*] - . simp [*] - simp_all + . -- TODO: simp[*] fails: "(deterministic) timeout at 'whnf'" + simp [hinv, h_veq] + simp_all end HashMap -- cgit v1.3.1 From 3337c4ac3326c3132dcc322f55f23a7d2054ceb0 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 26 Jul 2023 15:00:11 +0200 Subject: Update some of the Vec function specs --- backends/lean/Base/Primitives/Vec.lean | 13 ++++++++---- backends/lean/Base/Progress/Progress.lean | 17 ++++++++++----- tests/lean/Hashmap/Properties.lean | 35 +++++++++++++++++-------------- 3 files changed, 40 insertions(+), 25 deletions(-) (limited to 'backends/lean/Base/Progress') diff --git a/backends/lean/Base/Primitives/Vec.lean b/backends/lean/Base/Primitives/Vec.lean index 523372bb..a09d6ac2 100644 --- a/backends/lean/Base/Primitives/Vec.lean +++ b/backends/lean/Base/Primitives/Vec.lean @@ -85,14 +85,19 @@ def Vec.index (α : Type u) (v: Vec α) (i: Usize) : Result α := | none => fail .arrayOutOfBounds | some x => ret x +/- In the theorems below: we don't always need the `∃ ..`, but we use one + so that `progress` introduces an opaque variable and an equality. This + helps control the context. + -/ + @[pspec] theorem Vec.index_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) (hbound : i.val < v.length) : - v.index α i = ret (v.val.index i.val) := by + ∃ x, v.index α i = ret x ∧ x = v.val.index i.val := by simp only [index] -- TODO: dependent rewrite have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp only [*] + simp [*] -- This shouldn't be used def Vec.index_back (α : Type u) (v: Vec α) (i: Usize) (_: α) : Result Unit := @@ -109,11 +114,11 @@ def Vec.index_mut (α : Type u) (v: Vec α) (i: Usize) : Result α := @[pspec] theorem Vec.index_mut_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) (hbound : i.val < v.length) : - v.index_mut α i = ret (v.val.index i.val) := by + ∃ x, v.index_mut α i = ret x ∧ x = v.val.index i.val := by simp only [index_mut] -- TODO: dependent rewrite have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp only [*] + simp [*] instance {α : Type u} (p : Vec α → Prop) : Arith.HasIntProp (Subtype p) where prop_ty := λ x => p x diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 9300edff..6a4729dc 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -162,6 +162,7 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) allGoals asmTac let newGoals ← getUnsolvedGoals setGoals (newGoals ++ curGoals) + trace[Progress] "progress: replaced the goals" -- pure .Ok @@ -281,12 +282,15 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do | [keepArg, withArg, asArgs] => do pure (keepArg, withArg, asArgs) | _ => throwError "Unexpected: invalid arguments" let keep : Option Name ← do + trace[Progress] "Keep arg: {keepArg}" let args := keepArg.getArgs - trace[Progress] "Keep args: {args}" - let arg := args.get! 1 - trace[Progress] "Keep arg: {arg}" - if arg.isIdent then pure (some arg.getId) - else do pure (some (← mkFreshAnonPropUserName)) + if args.size > 0 then do + trace[Progress] "Keep args: {args}" + let arg := args.get! 1 + trace[Progress] "Keep arg: {arg}" + if arg.isIdent then pure (some arg.getId) + else do pure (some (← mkFreshAnonPropUserName)) + else do pure none trace[Progress] "Keep: {keep}" let withArg ← do let withArg := withArg.getArgs @@ -328,7 +332,10 @@ def evalProgress (args : TSyntax `Progress.progressArgs) : TacticM Unit := do else throwError "Not a linear arithmetic goal" progressAsmsOrLookupTheorem keep withArg ids splitPost ( + withMainContext do + trace[Progress] "trying to solve assumption: {← getMainGoal}" firstTac [assumptionTac, scalarTac]) + trace[Diverge] "Progress done" elab "progress" args:progressArgs : tactic => evalProgress args diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index 96b8193d..5d340b5c 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -285,7 +285,7 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value | none => nhm.len_s = hm.len_s + 1 | some _ => nhm.len_s = hm.len_s) := by rw [insert_no_resize] - simp [hash_key] + simp only [hash_key, bind_tc_ret] -- TODO: annoying have _ : (Vec.len (List α) hm.slots).val ≠ 0 := by checkpoint intro simp_all [inv] @@ -297,10 +297,9 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value simp [hinv] -- TODO: we want to automate that simp [*, Int.emod_lt_of_pos] - -- have h := Primitives.Vec.index_mut_spec hm.slots hash_mod -- TODO: change the spec of Vec.index_mut to introduce a let-binding. -- or: make progress introduce the let-binding by itself (this is clearer) - progress + progress as ⟨ l, h_leq ⟩ -- TODO: make progress use the names written in the goal progress as ⟨ inserted ⟩ rw [if_update_eq] -- TODO: necessary because we don't have a join @@ -311,38 +310,42 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value := by if inserted then simp [*] - have : hm.num_entries.val + (Usize.ofInt 1).val ≤ Usize.max := by + have hbounds : hm.num_entries.val + (Usize.ofInt 1).val ≤ Usize.max := by simp [lookup] at hnsat simp_all simp [inv] at hinv int_tac - progress - simp_all + -- 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. + have ⟨ z, hp ⟩ := Usize.add_spec hbounds + simp [hp] else - simp_all [Pure.pure] + simp [*, Pure.pure] progress as ⟨ i0 ⟩ -- TODO: progress "eager" to match premises with assumptions while instantiating -- meta-variables - have h_slot : slot_s_inv_hash hm.slots.length (hash_mod_key key hm.slots.length) - (List.v (List.index (hm.slots.val) hash_mod.val)) := by + have h_slot : slot_s_inv_hash hm.slots.length (hash_mod_key key hm.slots.length) l.v + := by simp [inv] at hinv have h := (hinv.right.left hash_mod.val (by assumption) (by assumption)).right simp [slot_t_inv, hhm] at h - simp [h, hhm] - have hd : distinct_keys (hm.slots.v.index hash_mod.val).v := by checkpoint + simp [h, hhm, h_leq] + have hd : distinct_keys l.v := by checkpoint simp [inv, slots_t_inv, slot_t_inv] at hinv have h := hinv.right.left hash_mod.val (by assumption) (by assumption) - simp [h] + simp [h, h_leq] -- TODO: hide the variables and only keep the props -- TODO: allow providing terms to progress to instantiate the meta variables -- which are not propositions progress as ⟨ l0, _, _, _, hlen .. ⟩ - -- Finishing the proof progress keep hv as ⟨ v, h_veq ⟩ -- TODO: update progress to automate that let nhm : HashMap α := { num_entries := i0, max_load_factor := hm.max_load_factor, max_load := hm.max_load, slots := v } exists nhm - -- TODO: later I don't want to inline nhm - we need to control simp + -- TODO: later I don't want to inline nhm - we need to control simp: deactivate + -- zeta reduction? have hupdt : lookup nhm key = some value := by checkpoint simp [lookup, List.lookup] at * simp_all @@ -387,7 +390,7 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value rename_i heq <;> simp [heq] at hlen <;> -- TODO: canonize addition by default? We need a tactic to simplify arithmetic equalities - -- with addition and substractions ((ℤ, +) is a ring or something - there should exist a tactic + -- 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] <;> int_tac @@ -403,7 +406,7 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value . simp [slots_t_inv, slot_t_inv] at * intro i hipos _ have _ := hinv.right.left i hipos (by simp_all) - simp [hhm, h_veq] at * -- TODO: annoying + simp [hhm, h_veq] at * -- TODO: annoying, we do that because simp_all fails below -- We need a case disjunction if h_ieq : i = key.val % _root_.List.len hm.slots.val then -- TODO: simp_all fails: "(deterministic) timeout at 'whnf'" -- cgit v1.3.1