From 66e66857a33ee266b9b11f6e97cd73d0fda67e7d Mon Sep 17 00:00:00 2001 From: James Date: Wed, 17 Apr 2024 04:25:25 -0400 Subject: [PATCH 1/2] Add files from CPOG checker --- Experiments/CPOG/Checker/CheckerCore.lean | 1210 +++++++++++++++++++++ Experiments/CPOG/Checker/Parse.lean | 177 +++ Experiments/CPOG/Count/Pog.lean | 344 ++++++ Experiments/CPOG/Count/PropForm.lean | 581 ++++++++++ Experiments/CPOG/Data/ClauseDb.lean | 612 +++++++++++ Experiments/CPOG/Data/HashMap/Basic.lean | 352 ++++++ Experiments/CPOG/Data/HashMap/Lemmas.lean | 524 +++++++++ Experiments/CPOG/Data/HashMap/WF.lean | 348 ++++++ Experiments/CPOG/Data/HashSet.lean | 259 +++++ Experiments/CPOG/Data/ICnf.lean | 698 ++++++++++++ Experiments/CPOG/Data/Pog.lean | 648 +++++++++++ Experiments/CPOG/Main.lean | 65 ++ Experiments/CPOG/Model/Cpog.lean | 167 +++ Experiments/CPOG/Model/Extensions.lean | 76 ++ Experiments/CPOG/Model/PropForm.lean | 231 ++++ Experiments/CPOG/Model/PropTerm.lean | 320 ++++++ Experiments/CPOG/Model/PropVars.lean | 399 +++++++ Experiments/CPOG/Model/ToMathlib.lean | 309 ++++++ 18 files changed, 7320 insertions(+) create mode 100644 Experiments/CPOG/Checker/CheckerCore.lean create mode 100644 Experiments/CPOG/Checker/Parse.lean create mode 100644 Experiments/CPOG/Count/Pog.lean create mode 100644 Experiments/CPOG/Count/PropForm.lean create mode 100644 Experiments/CPOG/Data/ClauseDb.lean create mode 100644 Experiments/CPOG/Data/HashMap/Basic.lean create mode 100644 Experiments/CPOG/Data/HashMap/Lemmas.lean create mode 100644 Experiments/CPOG/Data/HashMap/WF.lean create mode 100644 Experiments/CPOG/Data/HashSet.lean create mode 100644 Experiments/CPOG/Data/ICnf.lean create mode 100644 Experiments/CPOG/Data/Pog.lean create mode 100644 Experiments/CPOG/Main.lean create mode 100644 Experiments/CPOG/Model/Cpog.lean create mode 100644 Experiments/CPOG/Model/Extensions.lean create mode 100644 Experiments/CPOG/Model/PropForm.lean create mode 100644 Experiments/CPOG/Model/PropTerm.lean create mode 100644 Experiments/CPOG/Model/PropVars.lean create mode 100644 Experiments/CPOG/Model/ToMathlib.lean diff --git a/Experiments/CPOG/Checker/CheckerCore.lean b/Experiments/CPOG/Checker/CheckerCore.lean new file mode 100644 index 0000000..8d0baaf --- /dev/null +++ b/Experiments/CPOG/Checker/CheckerCore.lean @@ -0,0 +1,1210 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import Std.Data.Array.Basic + +import ProofChecker.Data.ClauseDb +import ProofChecker.Data.Pog +import ProofChecker.Count.Pog +import ProofChecker.Data.HashSet +import ProofChecker.Model.Cpog + +/-- An index into the `ClauseDb`. -/ +abbrev ClauseIdx := Nat + +/-- A step in a CPOG proof. -/ +inductive CpogStep + | /-- Add asymmetric tautology. -/ + addAt (idx : ClauseIdx) (C : IClause) (upHints : Array ClauseIdx) + | /-- Delete asymmetric tautology. -/ + delAt (idx : ClauseIdx) (upHints : Array ClauseIdx) + | /-- Declare product operation. -/ + prod (idx : ClauseIdx) (x : Var) (ls : Array ILit) + | /-- Declare sum operation. -/ + sum (idx : ClauseIdx) (x : Var) (l₁ l₂ : ILit) (upHints : Array ClauseIdx) + | /-- Declare POG root. -/ + root (r : ILit) + +namespace CpogStep + +def toDimacs : CpogStep → String + | addAt idx C upHints => s!"{idx} a {pArray C} 0 {pArray upHints} 0" + | delAt idx upHints => s!"dc {idx} {pArray upHints} 0" + | prod idx x ls => s!"{idx} p {x} {pArray ls} 0" + | sum idx x l₁ l₂ upHints => s!"{idx} s {x} {l₁} {l₂} {pArray upHints} 0" + | root x => s!"r {x}" +where + pArray {α : Type} [ToString α] (a : Array α) := + " ".intercalate (a.foldr (init := []) fun a acc => toString a :: acc) + +instance : ToString CpogStep where + toString := fun + | addAt idx C upHints => s!"{idx} a {C} 0 (hints: {upHints})" + | delAt idx upHints => s!"dc {idx} (hints: {upHints})" + | prod idx x ls => s!"{idx} p {x} {ls}" + | sum idx x l₁ l₂ upHints => s!"{idx} s {x} {l₁} {l₂} (hints: {upHints})" + | root x => s!"r {x}" + +end CpogStep + +inductive CheckerError where + | graphUpdateError (err : PogError) + | duplicateClauseIdx (idx : ClauseIdx) + | unknownClauseIdx (idx : ClauseIdx) + | pogDefClause (idx : ClauseIdx) + | hintNotPog (idx : ClauseIdx) + | hintNotUnit (idx : ClauseIdx) (C : IClause) (σ : PartPropAssignment) + | upNoContradiction (τ : PartPropAssignment) + | duplicateExtVar (x : Var) + | unknownVar (x : Var) + | depsNotDisjoint (xs : List Var) + | finalRootNotSet + | finalRootNotUnit (r : ILit) + | finalClausesInvalid + | finalClauseInvalid (idx : ClauseIdx) (C : IClause) + +namespace CheckerError + +instance : ToString CheckerError where + toString := fun + | graphUpdateError e => s!"graph update error: {e}" + | duplicateClauseIdx idx => s!"cannot add clause at index {idx}, index is already used" + | unknownClauseIdx idx => s!"there is no clause at index {idx}" + | pogDefClause idx => s!"clause at index {idx} cannot be deleted because it is a POG definition" + | hintNotPog idx => s!"hint {idx} cannot be used to imply model disjointness because it's not + a POG definition clause" + | hintNotUnit idx C σ => + s!"hinted clause {C} at index {idx} did not become unit under assignment {σ}" + | upNoContradiction τ => + s!"unit propagation did not derive contradiction (final assignment {τ})" + | duplicateExtVar x => s!"extension variable {x} was already introduced" + | unknownVar x => s!"unknown variable {x}" + | depsNotDisjoint xs => s!"variables {xs} have non-disjoint dependency sets" + | finalRootNotSet => s!"proof done but root literal was not set" + | finalRootNotUnit r => s!"proof done but root literal {r} was not asserted as a unit clause" + | finalClausesInvalid => + s!"proof done but some clause is neither the asserted root nor a POG definition" + | finalClauseInvalid idx C => + s!"proof done but clause {C} at index {idx} is neither the asserted root nor a POG definition" + +end CheckerError + +/-- The checker's runtime state. Contains exactly the data needed to fully check a proof. +It can be ill-formed, so it's a "pre"-well-formed state. -/ +structure PreState where + -- NOTE: This is part of the state so we could cheat by changing it. We don't. + inputCnf : ICnf + + /-- The variables present in the original CNF. -/ + -- TODO: not used at the moment; its cardinality is needed to output an absolute model-count, + -- and also to state invariants; but for the latter, ghost state would suffice + origVars : HashSet Var + + /-- The clause database. -/ + clauseDb : ClauseDb ClauseIdx + + /-- Which clauses are POG definition clauses. -/ + pogDefs : HashSet ClauseIdx + + /-- The partitioned-operation graph. -/ + pog : Pog + + /-- Maps any variable present in `pog` to the set of all *original* variables it depends on. + For example, an original `x` is mapped to `{x}` whereas an extension `p` with `p ↔ x ∧ y` is + mapped to `{x, y}`. + + Variables not present in `pog` are not present in this map. Thus we maintain the invariant + that a variable is in the `pog` iff it is in the domain of this map. -/ + depVars : HashMap Var (HashSet Var) + + /-- The POG root literal, if we already saw a `root` instruction. Otherwise `none`. -/ + root : Option ILit + +def PreState.pogDefs' (st : PreState) : Finset ClauseIdx := + st.pogDefs.toFinset + +noncomputable def PreState.pogDefsTerm (st : PreState) : PropTerm Var := + st.clauseDb.toPropTermSub st.pogDefs' + +def PreState.allVars (st : PreState) : Set Var := + { x | st.depVars.contains x } + +open PropTerm + +structure PreState.WF (st : PreState) : Prop where + /-- The POG definition clauses are all in the clause database. -/ + pogDefs_in_clauseDb : ∀ idx : ClauseIdx, idx ∈ st.pogDefs' → st.clauseDb.contains idx + + /-- Variable dependencies are correctly stored in `depVars`. -/ + depVars_pog : ∀ (x : Var) (D : HashSet Var), st.depVars.find? x = some D → + -- NOTE: can strengthen to eq if needed + (st.pog.toPropForm x).vars ⊆ D.toFinset + + /-- Every formula in the POG forest is partitioned. + + For literals not defining anything in the forest this still holds by fiat because + `st.pog.toPropForm l = l.toPropForm`. -/ + partitioned : ∀ x : Var, (st.pog.toPropForm x).partitioned + + /-- `depVars` contains all variables that influence the clause database. Contrapositive: + if a variable is not in `depVars` then it does not influence the clause database so can be + defined as an extension variable. -/ + clauseDb_semVars_sub : ↑st.clauseDb.toPropTerm.semVars ⊆ st.allVars + + pogDefsTerm_semVars_sub : ↑st.pogDefsTerm.semVars ⊆ st.allVars + + inputCnf_vars_sub : ↑st.inputCnf.vars.toFinset ⊆ st.allVars + + /-- Every formula in the POG forest lives over the original variables. -/ + pog_vars : ∀ x : Var, x ∈ st.allVars → + (st.pog.toPropForm x).vars ⊆ st.inputCnf.vars.toFinset + + /-- The clause database is equivalent to the original formula over original variables. -/ + equivalent_clauseDb : equivalentOver st.inputCnf.vars.toFinset + st.inputCnf.toPropTerm st.clauseDb.toPropTerm + + extends_pogDefsTerm : ∀ (σ₁ : PropAssignment Var), ∃ (σ₂ : PropAssignment Var), + σ₂.agreeOn st.inputCnf.vars.toFinset σ₁ ∧ σ₂ ⊨ st.pogDefsTerm + + /-- The POG definition clauses extend uniquely from the original variables to the current set + of variables. -/ + uep_pogDefsTerm : hasUniqueExtension st.inputCnf.vars.toFinset st.allVars + st.pogDefsTerm + + /-- In the context of the POG defining clauses, every variable is s-equivalent over original + variables to what it defines in the POG forest. -/ + -- TODO: could this be weakened to `extendsOver` and still go through? + equivalent_lits : ∀ x : Var, equivalentOver st.inputCnf.vars.toFinset + (.var x ⊓ st.pogDefsTerm) ⟦st.pog.toPropForm x⟧ + +theorem PreState.WF.depVars_pog' {st : PreState} (hWf : st.WF) (l : ILit) (D : HashSet Var) : + st.depVars.find? l.var = some D → (st.pog.toPropForm l).vars ⊆ D.toFinset := + fun hFind => l.mkPos_or_mkNeg.elim (· ▸ hWf.depVars_pog l.var D hFind) fun h => by + rw [h, Pog.toPropForm_neg, PropForm.vars] + exact hWf.depVars_pog l.var D hFind + +theorem PreState.WF.partitioned' {st : PreState} (hWf : st.WF) (l : ILit) : + (st.pog.toPropForm l).partitioned := + l.mkPos_or_mkNeg.elim (· ▸ hWf.partitioned l.var) fun h => by + rw [h, Pog.toPropForm_neg] + exact hWf.partitioned l.var + +theorem PreState.WF.pog_vars' {st : PreState} (hWf : st.WF) (l : ILit) : + l.var ∈ st.allVars → (st.pog.toPropForm l).vars ⊆ st.inputCnf.vars.toFinset := + fun hMem => l.mkPos_or_mkNeg.elim (· ▸ hWf.pog_vars l.var hMem) fun h => by + rw [h, Pog.toPropForm_neg] + exact hWf.pog_vars l.var hMem + +theorem PreState.WF.pog_semVars {st : PreState} (hWf : st.WF) (l : ILit) : + l.var ∈ st.allVars → ↑(PropTerm.semVars ⟦st.pog.toPropForm l⟧) ⊆ st.inputCnf.vars.toFinset := + fun hMem => subset_trans (PropForm.semVars_subset_vars _) (hWf.pog_vars' l hMem) + +theorem PreState.WF.equivalent_lits' {st : PreState} (hWf : st.WF) (l : ILit) : + l.var ∈ st.allVars → equivalentOver st.inputCnf.vars.toFinset + (l.toPropTerm ⊓ st.pogDefsTerm) ⟦st.pog.toPropForm l⟧ := by + intro hMem + cases l.mkPos_or_mkNeg + next hMk => + rw [hMk] + simp [hWf.equivalent_lits l.var] + next hMk => + rw [hMk] + generalize l.var = x at hMem ⊢ + have hEquiv := hWf.equivalent_lits x + simp only [Pog.toPropForm_neg, ILit.toPropTerm_mkNeg, PropTerm.mk_neg] + apply equivalentOver_iff_extendsOver _ _ _ |>.mpr + constructor + . intro σ hσ + refine ⟨σ, PropAssignment.agreeOn_refl _ _, ?_⟩ + rw [satisfies_neg] + intro h + have ⟨σ₂, hAgree, hσ₂⟩ := hEquiv σ |>.mpr ⟨σ, PropAssignment.agreeOn_refl _ _, h⟩ + have hAgree := hWf.uep_pogDefsTerm (satisfies_conj.mp hσ₂).right (satisfies_conj.mp hσ).right hAgree + have : σ₂.agreeOn (PropTerm.var x).semVars σ := hAgree.subset (by simp [hMem]) + have : σ ⊨ .var x := agreeOn_semVars this |>.mp (satisfies_conj.mp hσ₂).left + have : σ ⊭ .var x := satisfies_neg.mp (satisfies_conj.mp hσ).left + contradiction + . intro σ hσ + have ⟨σ₁, hAgree, hσ₁⟩ := hWf.extends_pogDefsTerm σ + refine ⟨σ₁, hAgree, ?_⟩ + simp only [hσ₁, satisfies_conj, satisfies_neg, and_true] + intro h + have ⟨σ₂, hAgree₂, hσ₂⟩ := hEquiv σ₁ |>.mp + ⟨σ₁, PropAssignment.agreeOn_refl _ _, satisfies_conj.mpr ⟨h, hσ₁⟩⟩ + have hAgree := hAgree₂.trans hAgree + have hSub := hWf.pog_semVars (.mkPos x) hMem + have : σ ⊨ ⟦st.pog.toPropForm (.mkPos x)⟧ := + agreeOn_semVars (hAgree.subset hSub) |>.mp hσ₂ + simp [satisfies_neg] at hσ + contradiction + +/-- A well-formed checker state. -/ +def State := { st : PreState // st.WF } + +abbrev CheckerM := StateT State <| Except CheckerError + +def initialPog (nVars : Nat) : + Except CheckerError { p : Pog // ∀ l, p.toPropForm l = l.toPropForm } := do + -- NOTE: We add all input variables to the POG in-order because that's what the current + -- implementation expects, but this requirement is artificial. See `Pog.lean`. + nVars.foldM (init := ⟨Pog.empty, Pog.toPropForm_empty⟩) fun x ⟨acc, hAcc⟩ => + let x := ⟨x + 1, Nat.zero_lt_succ _⟩ + match h : acc.addVar x with + | .ok g => pure ⟨g, by + intro l' + by_cases hEq : x = l'.var + . rw [hEq] at h + exact acc.toPropForm_addVar_lit _ _ h + . rw [acc.toPropForm_addVar_lit_of_ne _ _ _ h hEq] + apply hAcc⟩ + | .error e => throw <| .graphUpdateError e + +def initialClauseVars (m : HashMap Var (HashSet Var)) (C : IClause) : HashMap Var (HashSet Var) := + C.foldl (init := m) fun m l => + m.insert l.var (HashSet.empty Var |>.insert l.var) + +theorem initialClauseVars₁ (m : HashMap Var (HashSet Var)) (C : IClause) (x : Var) : + (initialClauseVars m C).contains x ↔ x ∈ C.vars.toFinset ∨ m.contains x := by + simp only [initialClauseVars, IClause.mem_vars, Array.foldl_eq_foldl_data] + induction C.data generalizing m <;> + aesop (add norm HashMap.contains_insert) + +theorem initialClauseVars₂ (m : HashMap Var (HashSet Var)) (C : IClause) : + (∀ x D, m.find? x = some D → x ∈ D.toFinset) → + ∀ x D, (initialClauseVars m C).find? x = some D → x ∈ D.toFinset := by + simp only [initialClauseVars, Array.foldl_eq_foldl_data] + induction C.data generalizing m + . simp + next l _ ih => + intro _ _ _ + rw [List.foldl_cons] + apply ih + intro y + by_cases hEq : l.var = y <;> + aesop (add norm HashMap.find?_insert, norm HashMap.find?_insert_of_ne) + +def initialCnfVars (m : HashMap Var (HashSet Var)) (φ : ICnf) : HashMap Var (HashSet Var) := + φ.foldl (init := m) initialClauseVars + +theorem initialCnfVars₁ (m : HashMap Var (HashSet Var)) (φ : ICnf) (x : Var) : + (initialCnfVars m φ).contains x ↔ x ∈ φ.vars.toFinset ∨ m.contains x := by + simp only [initialCnfVars, ICnf.mem_vars, Array.foldl_eq_foldl_data] + induction φ.data generalizing m <;> + aesop (add norm initialClauseVars₁) + +theorem initialCnfVars₂ (m : HashMap Var (HashSet Var)) (φ : ICnf) : + (∀ x D, m.find? x = some D → x ∈ D.toFinset) → + ∀ x D, (initialCnfVars m φ).find? x = some D → x ∈ D.toFinset := by + simp only [initialCnfVars, Array.foldl_eq_foldl_data] + induction φ.data generalizing m + . simp + next C _ ih => + intro h _ _ + rw [List.foldl_cons] + apply ih + exact initialClauseVars₂ _ _ h + +def initialDepVars (inputCnf : ICnf) : { dv : HashMap Var (HashSet Var) // + { y | dv.contains y } = inputCnf.vars.toFinset ∧ + ∀ x D, dv.find? x = some D → x ∈ D.toFinset } := + let dv := initialCnfVars .empty inputCnf + have allVars_eq := by ext; simp [initialCnfVars₁] + have of_find := by apply initialCnfVars₂; simp + ⟨dv, allVars_eq, of_find⟩ + +def initial (inputCnf : ICnf) (nVars : Nat) : Except CheckerError State := do + let ⟨initPog, hInitPog⟩ ← initialPog nVars + let ⟨initDv, allVars_eq, hInitDv⟩ := initialDepVars inputCnf + let st := { + inputCnf + origVars := inputCnf.vars + clauseDb := .ofICnf inputCnf + pogDefs := .empty ClauseIdx + pog := initPog + depVars := initDv + root := none + } + have pogDefs'_empty : st.pogDefs' = ∅ := by + simp [PreState.pogDefs'] + have pogDefsTerm_tr : st.pogDefsTerm = ⊤ := by + rw [PreState.pogDefsTerm, pogDefs'_empty, Finset.coe_empty] + apply ClauseDb.toPropTermSub_emptySet + have allVars_eq : st.allVars = st.inputCnf.vars.toFinset := allVars_eq + have pfs := { + pogDefs_in_clauseDb := by + simp [pogDefs'_empty] + depVars_pog := by + intro x D hFind + simp [hInitPog, PropForm.vars, hInitDv x D hFind] + partitioned := by + simp [hInitPog, PropForm.partitioned] + clauseDb_semVars_sub := by + rw [allVars_eq, ClauseDb.toPropTerm_ofICnf] + apply ICnf.semVars_sub + pogDefsTerm_semVars_sub := by + rw [pogDefsTerm_tr, PropTerm.semVars_tr, Finset.coe_empty] + apply Set.empty_subset + inputCnf_vars_sub := by + rw [allVars_eq] + equivalent_clauseDb := by + rw [ClauseDb.toPropTerm_ofICnf] + apply PropTerm.equivalentOver_refl + pog_vars := by + simp [allVars_eq, hInitPog, PropForm.vars] + extends_pogDefsTerm := fun σ => + ⟨σ, PropAssignment.agreeOn_refl _ _, by simp [pogDefsTerm_tr]⟩ + uep_pogDefsTerm := by + simp only [pogDefsTerm_tr, PropTerm.semVars_tr, Finset.coe_empty, allVars_eq] + exact PropTerm.hasUniqueExtension_refl _ _ + equivalent_lits := by + simp [pogDefsTerm_tr, hInitPog, PropTerm.equivalentOver_refl] + } + return ⟨st, pfs⟩ + +/-- Check if `C` is an asymmetric tautology wrt the clause database. `C` must not be a tautology. -/ +def checkAtWithHints (db : ClauseDb ClauseIdx) (C : IClause) (hC : C.toPropTerm ≠ ⊤) + (hints : Array ClauseIdx) : + Except CheckerError { _u : Unit // db.toPropTermSub (· ∈ hints.data) ≤ C.toPropTerm } +:= do + match db.unitPropWithHintsDep C.toFalsifyingAssignment hints with + | .contradiction h => return ⟨(), (by + rw [IClause.toPropTerm_toFalsifyingAssignment C hC, ← le_himp_iff, himp_bot, compl_compl] at h + assumption)⟩ + | .extended τ _ => throw <| .upNoContradiction τ + | .hintNotUnit idx C σ => throw <| .hintNotUnit idx C σ + | .hintNonexistent idx => throw <| .unknownClauseIdx idx + +/-- Check if `C` is an asymmetric tautology wrt the clause database, or simply a tautology. -/ +def checkImpliedWithHints (db : ClauseDb ClauseIdx) (C : IClause) (hints : Array ClauseIdx) : + Except CheckerError { _u : Unit // db.toPropTermSub (· ∈ hints.data) ≤ C.toPropTerm } +:= do + -- TODO: We could maintain no-tautologies-in-clause-db as an invariant rather than dynamically + -- checking. Checking on every deletion could cause serious slowdown (but measure first!). + if hTauto : C.toPropTerm = ⊤ then + return ⟨(), by simp [hTauto]⟩ + else + checkAtWithHints db C hTauto hints + +def addClause (db₀ : ClauseDb ClauseIdx) (idx : ClauseIdx) (C : IClause) : + Except CheckerError { db : ClauseDb ClauseIdx // + db = db₀.addClause idx C ∧ + ¬db₀.contains idx ∧ + -- This is just for convenience as it can be proven directly from the other postconditions. + db.toPropTerm = db₀.toPropTerm ⊓ C.toPropTerm } := do + if h : db₀.contains idx then + throw <| .duplicateClauseIdx idx + else + return ⟨db₀.addClause idx C, rfl, h, db₀.toPropTerm_addClause_eq idx C h⟩ + +def addAt (idx : ClauseIdx) (C : IClause) (hints : Array ClauseIdx) : CheckerM Unit := do + let ⟨st, pfs⟩ ← get + let ⟨_, hImp⟩ ← checkImpliedWithHints st.clauseDb C hints + let ⟨db', hAdd, hContains, hEq⟩ ← addClause st.clauseDb idx C + let st' := { st with clauseDb := db' } + have hDb : st'.clauseDb.toPropTerm = st.clauseDb.toPropTerm := by + simp [hEq, st.clauseDb.toPropTerm_subset _ |>.trans hImp] + have hPogDefs : st'.pogDefsTerm = st.pogDefsTerm := by + have hMem : idx ∉ (st.pogDefs' : Set _) := fun h => + hContains (pfs.pogDefs_in_clauseDb _ h) + have : st'.pogDefs' = st.pogDefs' := rfl + rw [PreState.pogDefsTerm, this] + simp [PreState.pogDefsTerm, hAdd, st.clauseDb.toPropTermSub_addClause_of_not_mem C hMem] + have pfs' := { pfs with + pogDefs_in_clauseDb := fun idx h => by + have := pfs.pogDefs_in_clauseDb idx h + simp only [hAdd] + exact st.clauseDb.contains_addClause _ _ _ |>.mpr (Or.inl this) + equivalent_clauseDb := hDb ▸ pfs.equivalent_clauseDb + clauseDb_semVars_sub := hDb ▸ pfs.clauseDb_semVars_sub + pogDefsTerm_semVars_sub := hPogDefs ▸ pfs.pogDefsTerm_semVars_sub + equivalent_lits := hPogDefs ▸ pfs.equivalent_lits + extends_pogDefsTerm := hPogDefs ▸ pfs.extends_pogDefsTerm + uep_pogDefsTerm := hPogDefs ▸ pfs.uep_pogDefsTerm + } + set (σ := State) ⟨st', pfs'⟩ + +def getClause (db : ClauseDb ClauseIdx) (idx : ClauseIdx) : + Except CheckerError { C : IClause // db.getClause idx = some C } := + match db.getClause idx with + | some C => return ⟨C, rfl⟩ + | none => throw <| .unknownClauseIdx idx + +def delAt (idx : ClauseIdx) (hints : Array ClauseIdx) : CheckerM Unit := do + let ⟨st, pfs⟩ ← get + let ⟨C, hGet⟩ ← getClause st.clauseDb idx + -- NOTE: We could investigate whether the check is really necessary. + let ⟨_, hMem⟩ ← (if h : st.pogDefs.contains idx then + throw <| .pogDefClause idx + else + pure ⟨(), HashSet.not_mem_toFinset _ _ |>.mpr h⟩ + : Except CheckerError { _u : Unit // idx ∉ st.pogDefs' }) + let db' := st.clauseDb.delClause idx + -- The clause is AT by everything except itself. + let ⟨_, hImp⟩ ← checkImpliedWithHints db' C hints + let st' := { st with clauseDb := db' } + have hDb : st'.clauseDb.toPropTerm = st.clauseDb.toPropTerm := by + have : st'.clauseDb.toPropTerm = st'.clauseDb.toPropTerm ⊓ C.toPropTerm := by + have := st'.clauseDb.toPropTerm_subset _ |>.trans hImp + exact left_eq_inf.mpr this + rw [this] + simp [st.clauseDb.toPropTerm_delClause_eq _ _ hGet] + have hPogDefs : st'.pogDefsTerm = st.pogDefsTerm := + st.clauseDb.toPropTermSub_delClause_of_not_mem hMem + have pfs' := { pfs with + pogDefs_in_clauseDb := fun idx h => by + refine st.clauseDb.contains_delClause _ _ |>.mpr ⟨pfs.pogDefs_in_clauseDb idx h, ?_⟩ + intro hEq + exact hMem (hEq.symm ▸ h) + equivalent_clauseDb := hDb ▸ pfs.equivalent_clauseDb + clauseDb_semVars_sub := hDb ▸ pfs.clauseDb_semVars_sub + pogDefsTerm_semVars_sub := hPogDefs ▸ pfs.pogDefsTerm_semVars_sub + equivalent_lits := hPogDefs ▸ pfs.equivalent_lits + extends_pogDefsTerm := hPogDefs ▸ pfs.extends_pogDefsTerm + uep_pogDefsTerm := hPogDefs ▸ pfs.uep_pogDefsTerm + } + set (σ := State) ⟨st', pfs'⟩ + +def ensureFreshVar (st : PreState) (x : Var) : Except CheckerError { _u : Unit // + x ∉ st.allVars } := do + if h : st.depVars.contains x then + throw <| .duplicateExtVar x + else + return ⟨(), h⟩ + +def getDeps (st : PreState) (pfs : st.WF) (l : ILit) : Except CheckerError { D : HashSet Var // + l.var ∈ st.allVars ∧ + (st.pog.toPropForm l).vars ⊆ D.toFinset } := do + match h : st.depVars.find? l.var with + | some D => + return ⟨D, st.depVars.contains_iff _ |>.mpr ⟨D, h⟩, pfs.depVars_pog' _ _ h⟩ + | none => throw <| .unknownVar l.var + +def getDepsArray {st : PreState} (pfs : st.WF) (ls : Array ILit) : + Except CheckerError { Ds : Array (HashSet Var) // + (∀ l ∈ ls.data, l.var ∈ st.allVars) ∧ + Ds.size = ls.size ∧ + ∀ (i : Nat) (hI : i < ls.size) (hI' : i < Ds.size), + (st.pog.toPropForm ls[i]).vars ⊆ Ds[i].toFinset } := + let f l := + match st.depVars.find? l.var with + | some D => return D + | none => throw <| .unknownVar l.var + let x : Except CheckerError (Array (HashSet Var)) := ls.mapM f + match h : x with + | .error e => throw e + | .ok Ds => + have := Array.SatisfiesM_mapM (as := ls) (f := f) + -- Postcondition on the input + (motive := fun i => ∀ (j : Fin ls.size), j < i → ls[j].var ∈ st.allVars) + -- Postcondition on the outputs + (p := fun i val => (st.pog.toPropForm ls[i]).vars ⊆ val.toFinset) + (h0 := by simp) + (hs := by + dsimp + intro i ih + split + next h => + simp only [SatisfiesM_Except_eq] + intro D hEq + cases hEq + refine ⟨pfs.depVars_pog' _ _ h, ?_⟩ + intro j hJ + cases Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hJ) with + | inl hJ => exact ih j hJ + | inr hJ => + simp only [hJ] + exact st.depVars.contains_iff _ |>.mpr ⟨_, h⟩ + . simp) + have hLs := by + intro l hL + simp only [SatisfiesM_Except_eq] at this + have ⟨h, _⟩ := this _ h + have ⟨i, hI⟩ := Array.get_of_mem_data hL + exact hI ▸ h i i.isLt + have hDs := by + simp only [SatisfiesM_Except_eq] at this + have := this _ h + aesop + have hSz := by + apply SatisfiesM_Except_eq.mp ?_ _ h + apply Array.size_mapM + return ⟨Ds, hLs, hSz, hDs⟩ + +def addPogDefClause (db₀ : ClauseDb ClauseIdx) (pd₀ : HashSet ClauseIdx) + (idx : ClauseIdx) (C : IClause) (h : ∀ idx, idx ∈ pd₀.toFinset → db₀.contains idx) : + Except CheckerError { p : ClauseDb ClauseIdx × HashSet ClauseIdx // + p.1.toPropTerm = db₀.toPropTerm ⊓ C.toPropTerm ∧ + p.1.toPropTermSub (· ∈ p.2.toFinset) = db₀.toPropTermSub (· ∈ pd₀.toFinset) ⊓ C.toPropTerm ∧ + ∀ idx, idx ∈ p.2.toFinset → p.1.contains idx } := do + let ⟨db, hAdd, hNContains, hDb⟩ ← addClause db₀ idx C + let pd := pd₀.insert idx + + have hMem : idx ∈ pd.toFinset := by simp + have hContainsTrans : ∀ {idx}, db₀.contains idx → db.contains idx := fun h => by + rw [hAdd] + exact db₀.contains_addClause _ _ _ |>.mpr (Or.inl h) + have hContains : db.contains idx := by + rw [hAdd] + exact db₀.contains_addClause _ _ _ |>.mpr (Or.inr rfl) + have hHelper : db₀.toPropTermSub (· ∈ pd.toFinset) = db₀.toPropTermSub (· ∈ pd₀.toFinset) := by + apply db₀.toPropTermSub_subset_eq fun _ hMem => by simp; exact Or.inr hMem + intro idx hMem hContains + simp at hMem + cases hMem with + | inl h => + exfalso + exact hNContains (h ▸ hContains) + | inr hMem => exact hMem + have hPd : db.toPropTermSub (· ∈ pd.toFinset) = + db₀.toPropTermSub (· ∈ pd₀.toFinset) ⊓ C.toPropTerm := by + rw [← hHelper, hAdd] + exact db₀.toPropTermSub_addClause_eq _ hMem hNContains + have hPdDb : ∀ idx, idx ∈ pd.toFinset → db.contains idx := by + simp only [HashSet.toFinset_insert, Finset.mem_singleton, Finset.mem_insert] + intro _ h + cases h with + | inl h => exact h ▸ hContains + | inr hMem => exact hContainsTrans (h _ hMem) + + return ⟨(db, pd), hDb, hPd, hPdDb⟩ + +theorem def_ext_correct {st : PreState} (H : st.WF) (st' : PreState) (x : Var) (φ ψ : PropTerm Var) + (hDb : st'.clauseDb.toPropTerm = st.clauseDb.toPropTerm ⊓ (.biImpl (.var x) φ)) + (hPd : st'.pogDefsTerm = st.pogDefsTerm ⊓ (.biImpl (.var x) φ)) + (hAv : st'.allVars = insert x st.allVars) + (hPog₁ : ∀ y, x ≠ y → st'.pog.toPropForm (.mkPos y) = st.pog.toPropForm (.mkPos y)) + (hPog₂ : ⟦st'.pog.toPropForm (.mkPos x)⟧ = ψ) + (hEquiv : PropTerm.equivalentOver st.inputCnf.vars.toFinset (.var x ⊓ st'.pogDefsTerm) ψ) + (hφ : ↑φ.semVars ⊆ st.allVars) + (hX : x ∉ st.allVars) : + (PropTerm.equivalentOver st.inputCnf.vars.toFinset + st.inputCnf.toPropTerm st'.clauseDb.toPropTerm ∧ + (∀ σ₁, ∃ (σ₂ : PropAssignment Var), + σ₂.agreeOn st.inputCnf.vars.toFinset σ₁ ∧ σ₂ ⊨ st'.pogDefsTerm) ∧ + PropTerm.hasUniqueExtension st.inputCnf.vars.toFinset st'.allVars st'.pogDefsTerm ∧ + ∀ x, PropTerm.equivalentOver st.inputCnf.vars.toFinset + (.var x ⊓ st'.pogDefsTerm) ⟦st'.pog.toPropForm (.mkPos x)⟧) := + have hEquivAv : PropTerm.equivalentOver st.allVars st.clauseDb.toPropTerm st'.clauseDb.toPropTerm + := by + rw [hDb] + exact PropTerm.equivalentOver_def_ext st.clauseDb.toPropTerm φ (H.clauseDb_semVars_sub) hφ hX + have equiv := + H.equivalent_clauseDb.trans (hEquivAv.subset H.inputCnf_vars_sub) + have hUepInsert := + PropTerm.hasUniqueExtension_def_ext x st.pogDefsTerm φ hφ + have extend := by + intro σ + have ⟨σ₁, hAgree, h₁⟩ := H.extends_pogDefsTerm σ + let σ₂ := σ₁.set x (φ.eval σ₁) + have hAgree₂₁ : σ₂.agreeOn st.allVars σ₁ := PropAssignment.agreeOn_set_of_not_mem _ _ hX + have : σ₂ ⊨ st.pogDefsTerm := + agreeOn_semVars (hAgree₂₁.subset H.pogDefsTerm_semVars_sub) |>.mpr h₁ + have : σ₂ ⊨ φ ↔ σ₁ ⊨ φ := agreeOn_semVars (hAgree₂₁.subset hφ) + exact ⟨σ₂, hAgree₂₁.subset H.inputCnf_vars_sub |>.trans hAgree, by aesop⟩ + have uep := by + rw [hAv, hPd] + exact H.uep_pogDefsTerm.conj_right _ |>.trans hUepInsert + have hEquivVarNe : ∀ {y : Var}, x ≠ y → PropTerm.equivalentOver st.allVars + (.var y ⊓ st'.pogDefsTerm) (.var y ⊓ st.pogDefsTerm) := by + intro y hEq + suffices PropTerm.equivalentOver (st.allVars ∪ {y}) + (.var y ⊓ st'.pogDefsTerm) (.var y ⊓ st.pogDefsTerm) from + this.subset (Set.subset_union_left _ _) + rw [hPd, ← inf_assoc] + apply PropTerm.equivalentOver.symm + have hX : x ∉ st.allVars ∪ {y} := by simp [hEq, hX] + apply PropTerm.equivalentOver_def_ext _ _ ?_ (hφ.trans <| Set.subset_union_left _ _) hX + suffices ↑((PropTerm.var y).semVars ∪ st.pogDefsTerm.semVars) ⊆ st.allVars ∪ {y} from + subset_trans (PropTerm.semVars_conj _ _) this + intro y; simp + intro h; cases h with + | inl hEq => exact Or.inl hEq + | inr hMem => exact Or.inr (H.pogDefsTerm_semVars_sub hMem) + have equiv_vars := by + intro y + by_cases hEq : x = y + case neg => + rw [hPog₁ _ hEq] + exact (hEquivVarNe hEq).subset H.inputCnf_vars_sub |>.trans (H.equivalent_lits y) + case pos => + rw [← hEq, hPog₂] + exact hEquiv + ⟨equiv, extend, uep, equiv_vars⟩ + +def addPogDefClauses (db₀ : ClauseDb ClauseIdx) (pd₀ : HashSet ClauseIdx) + (idx : ClauseIdx) (ls : Array ILit) (f : ILit → IClause) + (h : ∀ idx, idx ∈ pd₀.toFinset → db₀.contains idx) : + Except CheckerError { p : ClauseDb ClauseIdx × HashSet ClauseIdx // + p.1.toPropTerm = db₀.toPropTerm ⊓ + PropForm.arrayConjTerm (ls.map fun l => (f l).toPropForm) ∧ + p.1.toPropTermSub (· ∈ p.2.toFinset) = db₀.toPropTermSub (· ∈ pd₀.toFinset) ⊓ + PropForm.arrayConjTerm (ls.map fun l => (f l).toPropForm) ∧ + ∀ idx, idx ∈ p.2.toFinset → p.1.contains idx } := do + let ⟨out, h₁, h₂, h₃⟩ ← loopM_with_invariant (State := ClauseDb ClauseIdx × HashSet ClauseIdx) + (n := ls.size) + (invariant := fun i ⟨db, pd⟩ => + db.toPropTerm = db₀.toPropTerm ⊓ + PropForm.listConjTerm (ls.data.take i |>.map fun l => (f l).toPropTerm) ∧ + db.toPropTermSub (· ∈ pd.toFinset) = db₀.toPropTermSub (· ∈ pd₀.toFinset) ⊓ + PropForm.listConjTerm (ls.data.take i |>.map fun l => (f l).toPropTerm) ∧ + ∀ idx, idx ∈ pd.toFinset → db.contains idx) + (start_state := ⟨(db₀, pd₀), by simp, by simp, h⟩) + (step := fun i ⟨(db, pd), ih₁, ih₂, ih₃⟩ => do + let l := ls[i] + let ⟨st', hDb, hPd, h⟩ ← addPogDefClause db pd (idx+i+1) (f l) ih₃ + have hEquiv : + PropForm.listConjTerm (ls.data.take (i + 1) |>.map fun l => (f l).toPropTerm) = + PropForm.listConjTerm (ls.data.take i |>.map fun l => (f l).toPropTerm) ⊓ + IClause.toPropTerm (f l) := by + ext + simp [PropForm.satisfies_listConjTerm, List.take_succ, List.get?_eq_get i.isLt, + Array.getElem_eq_data_get] + constructor + . aesop + . intro ⟨h₁, h₂⟩ φ h + cases h with + | inl h => + have ⟨l, hL, hφ⟩ := h + exact hφ ▸ h₁ l hL + | inr h => + simp_all + have hDb' := by rw [hDb, ih₁, inf_assoc, hEquiv] + have hPd' := by rw [hPd, ih₂, inf_assoc, hEquiv] + return ⟨st', hDb', hPd', h⟩) + have hDb := by + simp only [List.take_length] at h₁ + simp [PropForm.arrayConjTerm_eq_listConjTerm_data, Function.comp, h₁] + have hPd := by + simp only [List.take_length] at h₂ + simp [PropForm.arrayConjTerm_eq_listConjTerm_data, Function.comp, h₂] + return ⟨out, hDb, hPd, h₃⟩ + +def addProdClauses (db₀ : ClauseDb ClauseIdx) (pd₀ : HashSet ClauseIdx) + (idx : ClauseIdx) (x : Var) (ls : Array ILit) + (h : ∀ idx, idx ∈ pd₀.toFinset → db₀.contains idx) : + Except CheckerError { p : ClauseDb ClauseIdx × HashSet ClauseIdx // + p.1.toPropTerm = db₀.toPropTerm ⊓ + (.biImpl (.var x) ⟦PropForm.arrayConj (ls.map ILit.toPropForm)⟧) ∧ + p.1.toPropTermSub (· ∈ p.2.toFinset) = db₀.toPropTermSub (· ∈ pd₀.toFinset) ⊓ + (.biImpl (.var x) ⟦PropForm.arrayConj (ls.map ILit.toPropForm)⟧) ∧ + ∀ idx, idx ∈ p.2.toFinset → p.1.contains idx } := do + let ⟨(db₁, pd₁), hDb₁, hPd₁, h₁⟩ ← addPogDefClause db₀ pd₀ idx (ls.map (-·) |>.push (.mkPos x)) h + let ⟨(db₂, pd₂), hDb₂, hPd₂, h₂⟩ ← addPogDefClauses db₁ pd₁ idx ls (#[.mkNeg x, ·]) h₁ + have hEquiv : + IClause.toPropTerm (ls.map (-·) |>.push (.mkPos x)) ⊓ + PropForm.arrayConjTerm (ls.map (IClause.toPropForm #[ILit.mkNeg x, ·])) = + .biImpl (var x) ⟦PropForm.arrayConj (ls.map ILit.toPropForm)⟧ := by + ext τ + simp [-satisfies_mk, PropForm.satisfies_arrayConjTerm, IClause.satisfies_iff] + refine ⟨?mp, ?mpr⟩ + case mp => + intro ⟨_, h⟩ + have h : ∀ (l : ILit), l ∈ ls.data → τ ⊭ .var x ∨ τ ⊨ l.toPropTerm := fun l hL => by + have := h l hL + rw [IClause.satisfies_iff] at this + simp_all + cases h : τ x <;> + aesop + case mpr => + intro + refine ⟨?_, fun l hL => IClause.satisfies_iff.mpr ?_⟩ <;> + cases h : τ x <;> + aesop + have hDb := by + rw [hDb₂, hDb₁, inf_assoc, hEquiv] + have hPd := by + rw [hPd₂, hPd₁, inf_assoc, hEquiv] + return ⟨(db₂, pd₂), hDb, hPd, h₂⟩ + +def addConjToPog (g : Pog) (x : Var) (ls : Array ILit) : Except CheckerError { g' : Pog // + g.addConj x ls = .ok g' } := + match g.addConj x ls with + | .ok g' => pure ⟨g', rfl⟩ + | .error e => throw <| .graphUpdateError e + +def disjointUnion (ls : Array ILit) (Ds : Array (HashSet Var)) : + Except CheckerError { U : HashSet Var // + (∀ x, x ∈ U.toFinset ↔ ∃ D ∈ Ds.data, x ∈ D.toFinset) ∧ + ∀ (i j : Nat) (hI : i < Ds.size) (hJ : j < Ds.size), i ≠ j → + Ds[i].toFinset ∩ Ds[j].toFinset = ∅ } := + match h : HashSet.disjointUnion Ds with + | (U, true) => + have h₁ : (HashSet.disjointUnion Ds).fst = U := congrArg Prod.fst h + have h₂ : (HashSet.disjointUnion Ds).snd = true := congrArg Prod.snd h + return ⟨U, h₁ ▸ HashSet.mem_disjointUnion Ds, HashSet.disjoint_disjointUnion Ds h₂⟩ + | (_, false) => + throw <| .depsNotDisjoint (ls.toList.map ILit.var) + +def addProd (idx : ClauseIdx) (x : Var) (ls : Array ILit) : CheckerM Unit := do + let ⟨st, pfs⟩ ← get + + -- Check that added variable is fresh. + let ⟨_, hX⟩ ← ensureFreshVar st x + + -- Check that variables are known and compute their dependencies. + let ⟨Ds, hLs, hSz, hDs⟩ ← getDepsArray pfs ls + + -- Compute total dependency set and check pairwise disjointness. + let ⟨U, hU, hDisjoint⟩ ← disjointUnion ls Ds + + let ⟨pog', hPog⟩ ← addConjToPog st.pog x ls + + let ⟨(db', pd'), hDb, hPd, pogDefs_in_clauseDb⟩ ← + addProdClauses st.clauseDb st.pogDefs idx x ls pfs.pogDefs_in_clauseDb + + let st' := { st with + clauseDb := db' + pogDefs := pd' + pog := pog' + depVars := st.depVars.insert x U + } + + have hPd : st'.pogDefsTerm = st.pogDefsTerm ⊓ + (.biImpl (.var x) ⟦PropForm.arrayConj (ls.map ILit.toPropForm)⟧) := hPd + + have hDb : st'.clauseDb.toPropTerm = st.clauseDb.toPropTerm ⊓ + (.biImpl (.var x) ⟦PropForm.arrayConj (ls.map ILit.toPropForm)⟧) := hDb + + have hVars : (PropForm.arrayConj (ls.map st.pog.toPropForm)).vars ⊆ U.toFinset := by + intro x + simp only [PropForm.mem_vars_arrayConj, getElem_fin, Array.getElem_map] + intro ⟨i, hMem⟩ + have hI : i < ls.size := Array.size_map st.pog.toPropForm ls ▸ i.isLt + have := hDs i hI (hSz ▸ hI) hMem + exact hU x |>.mpr ⟨_, Array.getElem_mem_data _ _, this⟩ + + have hSemVars : ↑(PropTerm.semVars ⟦PropForm.arrayConj (ls.map ILit.toPropForm)⟧) ⊆ st.allVars := + by + apply subset_trans (Finset.coe_subset.mpr <| PropForm.semVars_subset_vars _) + intro x + simp only [Finset.mem_coe, PropForm.mem_vars_arrayConj, getElem_fin, Array.getElem_map, + ILit.vars_toPropForm, Finset.mem_singleton] + intro ⟨i, h⟩ + exact h ▸ hLs ls[i] (Array.getElem_mem_data _ _) + + have hAv : st'.allVars = insert x st.allVars := by + ext + simp [PreState.allVars, HashMap.contains_insert, @eq_comm _ x, or_comm] + + have ⟨equivalent_clauseDb, extends_pogDefsTerm, uep_pogDefsTerm, equivalent_lits⟩ := + def_ext_correct pfs st' + x ⟦PropForm.arrayConj (ls.map ILit.toPropForm)⟧ ⟦PropForm.arrayConj (ls.map st.pog.toPropForm)⟧ + hDb hPd hAv + (fun l hNe => st.pog.toPropForm_addConj_lit_of_ne _ _ _ _ (by exact hPog) hNe) + (by simp [st.pog.toPropForm_addConj _ _ _ hPog]) + (by + rw [hPd] + exact addConj_new_var_equiv + st.pog st.pogDefsTerm ls + hX pfs.inputCnf_vars_sub pfs.pogDefsTerm_semVars_sub pfs.uep_pogDefsTerm + pfs.extends_pogDefsTerm + fun l hL => + have hMem := hLs l hL + ⟨hMem, pfs.pog_semVars l hMem, pfs.equivalent_lits' l hMem⟩) + hSemVars hX + + have pfs' := { + pogDefs_in_clauseDb + clauseDb_semVars_sub := by + rw [hAv, hDb] + apply subset_trans (Finset.coe_subset.mpr <| semVars_conj _ _) + rw [Finset.coe_union] + apply Set.union_subset + . exact subset_trans pfs.clauseDb_semVars_sub (Set.subset_insert _ _) + apply subset_trans (Finset.coe_subset.mpr <| semVars_biImpl _ _) + rw [Finset.coe_union] + apply Set.union_subset + . simp + exact subset_trans hSemVars (Set.subset_insert _ _) + pogDefsTerm_semVars_sub := by + rw [hAv, hPd] + apply subset_trans (Finset.coe_subset.mpr <| semVars_conj _ _) + rw [Finset.coe_union] + apply Set.union_subset + . exact subset_trans pfs.pogDefsTerm_semVars_sub (Set.subset_insert _ _) + apply subset_trans (Finset.coe_subset.mpr <| semVars_biImpl _ _) + rw [Finset.coe_union] + apply Set.union_subset + . simp + exact subset_trans hSemVars (Set.subset_insert _ _) + inputCnf_vars_sub := + hAv ▸ pfs.inputCnf_vars_sub.trans (Set.subset_insert x st.allVars) + depVars_pog := by + intro y D hFind + by_cases hEq : x = y + . rw [st.pog.toPropForm_addConj _ _ _ (hEq ▸ hPog)] + rw [st.depVars.find?_insert _ (beq_iff_eq _ _ |>.mpr hEq)] at hFind + injection hFind with hFind + exact hFind ▸ hVars + . rw [st.pog.toPropForm_addConj_of_ne _ _ _ _ hPog hEq] + rw [st.depVars.find?_insert_of_ne _ (bne_iff_ne _ _ |>.mpr hEq)] at hFind + exact pfs.depVars_pog y D hFind + pog_vars := by + intro y hMem + simp only [hAv, Set.mem_insert_iff] at hMem + cases hMem with + | inl hEq => + intro x + simp only [hEq, st.pog.toPropForm_addConj _ _ _ hPog, PropForm.mem_vars_arrayConj, + getElem_fin, Array.getElem_map] + intro ⟨i, hMem⟩ + refine pfs.pog_vars' ls[i] ?_ hMem + exact hLs ls[i.val] (Array.getElem_mem_data _ _) + | inr hMem => + have hNe : x ≠ y := fun h => absurd hMem (h ▸ hX) + rw [st.pog.toPropForm_addConj_of_ne _ _ _ _ hPog hNe] + exact pfs.pog_vars y hMem + partitioned := by + intro y + by_cases hEq : x = y + . rw [st.pog.toPropForm_addConj _ _ _ (hEq ▸ hPog), PropForm.partitioned_arrayConj] + intro i + simp only [getElem_fin, Array.getElem_map] + constructor + . exact pfs.partitioned' (ls[i.val]) + . intro j hNe + have h := Array.size_map st.pog.toPropForm ls + have h' := h.trans hSz.symm + have hI := hDs i (h ▸ i.isLt) (h' ▸ i.isLt) + have hJ := hDs j (h ▸ j.isLt) (h' ▸ j.isLt) + have hIJ := hDisjoint i j (h' ▸ i.isLt) (h' ▸ j.isLt) (Fin.val_ne_of_ne hNe) + simp at hI hJ hIJ ⊢ + apply Finset.subset_empty.mp + exact hIJ ▸ Finset.inter_subset_inter hI hJ + . rw [st.pog.toPropForm_addConj_of_ne _ _ _ _ hPog hEq] + exact pfs.partitioned y + equivalent_clauseDb + extends_pogDefsTerm + uep_pogDefsTerm + equivalent_lits + } + set (σ := State) ⟨st', pfs'⟩ + +def addSumClauses (db₀ : ClauseDb ClauseIdx) (pd₀ : HashSet ClauseIdx) + (idx : ClauseIdx) (x : Var) (l₁ l₂ : ILit) (h : ∀ idx, idx ∈ pd₀.toFinset → db₀.contains idx) : + Except CheckerError { p : ClauseDb ClauseIdx × HashSet ClauseIdx // + p.1.toPropTerm = db₀.toPropTerm ⊓ + (.biImpl (.var x) (l₁.toPropTerm ⊔ l₂.toPropTerm)) ∧ + p.1.toPropTermSub (· ∈ p.2.toFinset) = db₀.toPropTermSub (· ∈ pd₀.toFinset) ⊓ + (.biImpl (.var x) (l₁.toPropTerm ⊔ l₂.toPropTerm)) ∧ + ∀ idx, idx ∈ p.2.toFinset → p.1.contains idx } := do + let ⟨(db₁, pd₁), hDb₁, hPd₁, h⟩ ← addPogDefClause db₀ pd₀ idx #[.mkNeg x, l₁, l₂] h + let ⟨(db₂, pd₂), hDb₂, hPd₂, h⟩ ← addPogDefClause db₁ pd₁ (idx+1) #[.mkPos x, -l₁] h + let ⟨(db₃, pd₃), hDb₃, hPd₃, h⟩ ← addPogDefClause db₂ pd₂ (idx+2) #[.mkPos x, -l₂] h + have hDb := by + rw [hDb₃, hDb₂, hDb₁] + simp [IClause.toPropTerm, inf_assoc, PropTerm.disj_def_eq] + have hPd := by + rw [hPd₃, hPd₂, hPd₁] + simp [IClause.toPropTerm, inf_assoc, PropTerm.disj_def_eq] + return ⟨(db₃, pd₃), hDb, hPd, h⟩ + +def ensurePogHints (st : PreState) (hints : Array ClauseIdx) : + Except CheckerError { _u : Unit // + ∀ idx, idx ∈ hints.data → idx ∈ st.pogDefs' } := do + match hSz : hints.size with + | 0 => + return ⟨(), fun _ hMem => by + dsimp [Array.size] at hSz + rw [List.length_eq_zero.mp hSz] at hMem + contradiction⟩ + | i+1 => + let ⟨_, h⟩ ← go i (hSz ▸ Nat.lt_succ_self _) (fun j hLt => by + have := j.isLt + linarith) + return ⟨(), fun _ hMem => have ⟨i, hI⟩ := Array.get_of_mem_data hMem; hI ▸ h i⟩ +where go (i : Nat) (hLt : i < hints.size) + (ih : ∀ (j : Fin hints.size), i < j → hints[j] ∈ st.pogDefs') : + Except CheckerError { _u : Unit // ∀ (j : Fin hints.size), hints[j] ∈ st.pogDefs' } := do + let idx := hints[i] + if hContains : st.pogDefs.contains idx then + have hContains : hints[i] ∈ st.pogDefs' := + by simp [PreState.pogDefs', HashSet.mem_toFinset, hContains] + match hI : i, hLt, ih with + | 0, hLt, ih => + return ⟨(), fun j => by + cases j.val.eq_zero_or_pos with + | inl hEq => + -- Why does this compute a correct motive while `rw` doesn't? + simp only [hI] at hContains + simp [hEq, hContains] + | inr hLt => + exact ih j hLt⟩ + | i+1, hLt, ih => + by exact -- Hmmm + go i (Nat.lt_of_succ_lt hLt) (fun j hLt => by + cases Nat.eq_or_lt_of_le hLt with + | inl hEq => + simp only [hI] at hContains + simp [← hEq, hContains] + | inr hLt => + exact ih j hLt) + else + throw <| .hintNotPog idx + +def addDisjToPog (g : Pog) (x : Var) (l₁ l₂ : ILit) : Except CheckerError { g' : Pog // + g.addDisj x l₁ l₂ = .ok g' } := + match g.addDisj x l₁ l₂ with + | .ok g' => pure ⟨g', rfl⟩ + | .error e => throw <| .graphUpdateError e + +def addSum (idx : ClauseIdx) (x : Var) (l₁ l₂ : ILit) (hints : Array ClauseIdx) : + CheckerM Unit := do + let ⟨st, pfs⟩ ← get + + -- Check that added variable is fresh. + let ⟨_, hX⟩ ← ensureFreshVar st x + + -- Check that variables are known and compute their dependencies. + let ⟨D₁, hL₁, hD₁⟩ ← getDeps st pfs l₁ + let ⟨D₂, hL₂, hD₂⟩ ← getDeps st pfs l₂ + + -- Check that POG defs imply that the children have no models in common. + let ⟨_, hHints⟩ ← ensurePogHints st hints + -- NOTE: Important that this be done before adding clauses, for linearity. + let ⟨_, hImp⟩ ← checkImpliedWithHints st.clauseDb #[-l₁, -l₂] hints + + let ⟨pog', hPog⟩ ← addDisjToPog st.pog x l₁ l₂ + + let ⟨(db', pd'), hDb, hPd, pogDefs_in_clauseDb⟩ ← + addSumClauses st.clauseDb st.pogDefs idx x l₁ l₂ pfs.pogDefs_in_clauseDb + + let st' := { st with + clauseDb := db' + pogDefs := pd' + pog := pog' + depVars := st.depVars.insert x (D₁.union D₂) + } + + have hPd : st'.pogDefsTerm = st.pogDefsTerm ⊓ (.biImpl (.var x) (l₁.toPropTerm ⊔ l₂.toPropTerm)) + := hPd + + have hDb : st'.clauseDb.toPropTerm = st.clauseDb.toPropTerm ⊓ + (.biImpl (.var x) (l₁.toPropTerm ⊔ l₂.toPropTerm)) := + hDb + + have hDisjoint : st.pogDefsTerm ⊓ l₁.toPropTerm ⊓ l₂.toPropTerm ≤ ⊥ := by + have : st.pogDefsTerm ≤ st.clauseDb.toPropTermSub (· ∈ hints.data) := + st.clauseDb.toPropTermSub_subset hHints + rw [inf_assoc, ← le_himp_iff] + have := le_trans this hImp + simp [IClause.toPropTerm] at this + simp [this] + + have hSemVars : ↑(l₁.toPropTerm ⊔ l₂.toPropTerm).semVars ⊆ st.allVars := by + have : ↑(l₁.toPropTerm.semVars ∪ l₂.toPropTerm.semVars) ⊆ st.allVars := by + intro x h + simp at h + cases h <;> next h => simp only [h, hL₁, hL₂] + exact subset_trans (PropTerm.semVars_disj _ _) this + + have hAv : st'.allVars = insert x st.allVars := by + ext + simp [PreState.allVars, HashMap.contains_insert, @eq_comm _ x, or_comm] + + have ⟨equivalent_clauseDb, extends_pogDefsTerm, uep_pogDefsTerm, equivalent_lits⟩ := + def_ext_correct pfs st' + x (l₁.toPropTerm ⊔ l₂.toPropTerm) (⟦st.pog.toPropForm l₁⟧ ⊔ ⟦st.pog.toPropForm l₂⟧) + hDb hPd hAv + (fun l hNe => st.pog.toPropForm_addDisj_lit_of_ne _ _ _ _ _ (by exact hPog) hNe) + (by simp [st.pog.toPropForm_addDisj _ _ _ _ hPog]) + (by + rw [hPd, ← inf_assoc] + exact addDisj_new_var_equiv st.pogDefsTerm l₁.toPropTerm l₂.toPropTerm _ _ hX + (pfs.inputCnf_vars_sub) (pfs.pogDefsTerm_semVars_sub) + (by simp [hL₁]) (by simp [hL₂]) + (pfs.equivalent_lits' l₁ hL₁) (pfs.equivalent_lits' l₂ hL₂)) + hSemVars hX + + have pfs' := { + pogDefs_in_clauseDb + clauseDb_semVars_sub := by + rw [hAv, hDb] + apply subset_trans (Finset.coe_subset.mpr <| semVars_conj _ _) + rw [Finset.coe_union] + apply Set.union_subset + . exact subset_trans pfs.clauseDb_semVars_sub (Set.subset_insert _ _) + apply subset_trans (Finset.coe_subset.mpr <| semVars_biImpl _ _) + rw [Finset.coe_union] + apply Set.union_subset + . simp + exact subset_trans hSemVars (Set.subset_insert _ _) + pogDefsTerm_semVars_sub := by + rw [hAv, hPd] + apply subset_trans (Finset.coe_subset.mpr <| semVars_conj _ _) + rw [Finset.coe_union] + apply Set.union_subset + . exact subset_trans pfs.pogDefsTerm_semVars_sub (Set.subset_insert _ _) + apply subset_trans (Finset.coe_subset.mpr <| semVars_biImpl _ _) + rw [Finset.coe_union] + apply Set.union_subset + . simp + exact subset_trans hSemVars (Set.subset_insert _ _) + inputCnf_vars_sub := + hAv ▸ pfs.inputCnf_vars_sub.trans (Set.subset_insert x st.allVars) + depVars_pog := by + intro y D hFind + by_cases hEq : x = y + . rw [st.pog.toPropForm_addDisj _ _ _ _ (hEq ▸ hPog)] + rw [st.depVars.find?_insert _ (beq_iff_eq _ _ |>.mpr hEq)] at hFind + injection hFind with hFind + rw [PropForm.vars, ← hFind, HashSet.toFinset_union] + apply Finset.union_subset_union <;> assumption + . rw [st.pog.toPropForm_addDisj_of_ne _ _ _ _ _ hPog hEq] + rw [st.depVars.find?_insert_of_ne _ (bne_iff_ne _ _ |>.mpr hEq)] at hFind + exact pfs.depVars_pog y D hFind + pog_vars := by + intro y hMem + simp only [hAv, Set.mem_insert_iff] at hMem + cases hMem + next hEq => + simp only [hEq, st.pog.toPropForm_addDisj _ _ _ _ hPog, PropForm.vars] + exact Finset.union_subset (pfs.pog_vars' l₁ hL₁) (pfs.pog_vars' l₂ hL₂) + next hMem => + have hNe : x ≠ y := fun h => absurd hMem (h ▸ hX) + rw [st.pog.toPropForm_addDisj_of_ne _ _ _ _ _ hPog hNe] + exact pfs.pog_vars y hMem + partitioned := by + intro y + by_cases hEq : x = y + . rw [st.pog.toPropForm_addDisj _ _ _ _ (hEq ▸ hPog)] + refine addDisj_partitioned st.pogDefsTerm l₁.toPropTerm l₂.toPropTerm _ _ ?_ + pfs.uep_pogDefsTerm hDisjoint (pfs.equivalent_lits' l₁ hL₁) (pfs.equivalent_lits' l₂ hL₂) + (pfs.partitioned' l₁) (pfs.partitioned' l₂) + simp [hL₂] + . rw [st.pog.toPropForm_addDisj_of_ne _ _ _ _ _ hPog hEq] + exact pfs.partitioned y + equivalent_clauseDb + extends_pogDefsTerm + uep_pogDefsTerm + equivalent_lits + } + set (σ := State) ⟨st', pfs'⟩ + +def setRoot (r : ILit) : CheckerM Unit := do + modify fun ⟨st, pfs⟩ => ⟨{ st with root := some r }, { pfs with }⟩ + +def checkFinalClauses (r : ILit) (st : PreState) : Except CheckerError { _u : Unit // + (∀ idx C, st.clauseDb.getClause idx = some C → idx ∈ st.pogDefs' ∨ C = #[r]) + ∧ (∃ idxᵣ, st.clauseDb.getClause idxᵣ = some #[r]) } := do + /- NOTE: This check is seriously inefficient. First, `all`/`any` don't use early return. Second, + we loop over the clauses twice. Third, this could likely all be implemented in O(1) by storing + the number `nClauses` of clauses. As long as `nClauses = st.pogDefs.size + 1` (`+ 1` for the root + literal), the conclusion should follow from appropriate invariants. -/ + match h₁ : st.clauseDb.all (fun idx C => C = #[r] ∨ st.pogDefs.contains idx) with + | true => + match h₂ : st.clauseDb.any (fun _ C => C = #[r]) with + | true => + have hA := by + intro idx C hGet + have := st.clauseDb.all_true _ h₁ idx C hGet + simp at this + rw [PreState.pogDefs', HashSet.mem_toFinset] + exact Or.comm.mp this + have hE := by + have ⟨idxᵣ, C, hGet, hP⟩ := st.clauseDb.any_true _ h₂ + simp at hP + exact ⟨idxᵣ, hP ▸ hGet⟩ + return ⟨(), hA, hE⟩ + | false => throw <| .finalRootNotUnit r + | false => throw <| .finalClausesInvalid + +def checkFinalState : CheckerM { p : ICnf × Pog × ILit // + p.1.toPropTerm = ⟦p.2.1.toPropForm p.2.2⟧ } := do + let ⟨st, pfs⟩ ← get + + let some r := st.root + | throw <| .finalRootNotSet + let ⟨_, hR, _⟩ ← getDeps st pfs r + + let ⟨_, hA, hE⟩ ← checkFinalClauses r st + have : st.clauseDb.toPropTerm = r.toPropTerm ⊓ st.pogDefsTerm := by + have ⟨idxᵣ, hGet⟩ := hE + ext τ + rw [st.clauseDb.satisfies_toPropTerm, PreState.pogDefsTerm, satisfies_conj, + st.clauseDb.satisfies_toPropTermSub] + constructor + . intro h + have := h _ _ hGet + dsimp [IClause.toPropTerm] at this + aesop + . intro ⟨h₁, h₂⟩ _ _ hGet + cases hA _ _ hGet + next hMem => exact h₂ _ hMem _ hGet + next hEq => + rw [hEq] + simp [IClause.toPropTerm, h₁] + + have : st.inputCnf.toPropTerm = ⟦st.pog.toPropForm r⟧ := by + have := this ▸ pfs.equivalent_clauseDb + have := this.trans (pfs.equivalent_lits' r hR) + have hInputVars := PropForm.semVars_subset_vars st.inputCnf.toPropForm + simp at hInputVars + have hPogVars := subset_trans (PropForm.semVars_subset_vars _) (pfs.pog_vars' r hR) + exact equivalentOver_semVars hInputVars hPogVars this + + return ⟨(st.inputCnf, st.pog, r), this⟩ + +def checkProofStep (step : CpogStep) : CheckerM Unit := + match step with + | .addAt idx C hints => addAt idx C hints + | .delAt idx hints => delAt idx hints + | .prod idx x ls => addProd idx x ls + | .sum idx x l₁ l₂ hints => addSum idx x l₁ l₂ hints + | .root r => setRoot r + +/-- Check a CPOG proof and throw if it is invalid. If `count = True`, also return the model count +of `cnf` over `nVars` variables. Otherwise return an unspecified number. -/ +def checkProof (cnf : ICnf) (nVars : Nat) (pf : Array CpogStep) (count : Bool := False) : + Except String Nat := do + let mut st : State ← Except.mapError toString (initial cnf nVars) + for step in pf do + try + (_, st) ← Except.mapError toString (checkProofStep step |>.run st) + catch e => + throw <| s!"error on line '{step.toDimacs}':\n{e}" + let ⟨(_, _, r), _⟩ ← Except.mapError toString (checkFinalState.run' st) + if count then + if r.polarity = true then + return st.val.pog.count nVars r.var + else + return 2^nVars - st.val.pog.count nVars r.var + else + return 0 + +/- +-- LATER: re-add tracing + +/-- Wraps a well-formed checker state with extra stuff for tracing and debugging it. -/ +structure CheckerState' where + core : CheckerState + verbose : Bool := false + trace : Array String := #[] + +namespace CheckerState + +abbrev CheckerM := ExceptT CheckerError <| StateM CheckerState + +def withTraces (f : Array String → String) (x : CheckerM Unit) : CheckerM Unit := do + if (← get).verbose then + let prevTrace ← modifyGet fun st => (st.trace, { st with trace := #[] }) + try x + finally + modify fun st => { st with trace := prevTrace.push <| f st.trace } + else + x + +def log_ (msg : Unit → String) : CheckerM Unit := do + modify fun st => + if st.verbose then { st with trace := st.trace.push <| msg () } + else st + +syntax "log! " interpolatedStr(term) : term +macro_rules + | `(log! $interpStr) => `(log_ fun _ => s!$interpStr) + +end CheckerState +-/ \ No newline at end of file diff --git a/Experiments/CPOG/Checker/Parse.lean b/Experiments/CPOG/Checker/Parse.lean new file mode 100644 index 0000000..7a80783 --- /dev/null +++ b/Experiments/CPOG/Checker/Parse.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import ProofChecker.Data.ICnf +import ProofChecker.Checker.CheckerCore + +def Except.ofOption (e : ε) : Option α → Except ε α + | none => .error e + | some x => .ok x + +namespace Dimacs + +inductive Token where + | int (i : Int) | str (s : String) + deriving Repr, BEq + +instance : Coe String Token := + ⟨Token.str⟩ + +instance : Coe Int Token := + ⟨Token.int⟩ + +instance : ToString Token where + toString := fun | .int v | .str v => toString v + +def Token.getInt? : Token → Option Int + | .int i => some i + | .str _ => none + +def Token.getStr? : Token → Option String + | .int _ => none + | .str s => some s + +def tokenizeLines (lines : Array String) : Array (Array Token) := Id.run do + let mut lns := #[] + for ln in lines do + let tks := ln.splitOn " " |>.filter (· ≠ "") + if tks.isEmpty then continue + if tks.head! == "c" then continue + let mut ln := #[] + for tk in tks do + if let some i := tk.toInt? then + ln := ln.push <| .int i + else + ln := ln.push <| .str tk + lns := lns.push ln + return lns + +end Dimacs + +open Dimacs + +def Nat.ofToken : Token → Except String Nat + | .int i => + if 0 ≤ i then .ok (Int.natAbs i) + else .error s!"expected non-negative int at '{i}'" + | .str s => .error s!"expected int at '{s}'" + +def Var.ofToken : Token → Except String Var + | .int i => + if h : 0 < i then .ok ⟨Int.natAbs i, Int.natAbs_pos.mpr (Int.ne_of_gt h)⟩ + else .error s!"expected positive int at '{i}'" + | .str s => .error s!"expected int at '{s}'" + +def ILit.ofToken : Token → Except String ILit + | .int i => + if h : i ≠ 0 then .ok ⟨i, h⟩ + else .error s!"literal can't be zero at '{i}'" + | .str s => .error s!"expected int at '{s}'" + +def ILit.ofTokenBounded (bd : Nat) (tk : Token) : Except String ILit := do + let l ← ILit.ofToken tk + if l.var ≤ bd then + return l + else + throw s!"literal {l} exceeds maximum variable index {bd}" + +def IClause.ofTokens (tks : Array Token) : Except String IClause := do + tks.mapM ILit.ofToken + +def IClause.ofTokensBounded (bd : Nat) (tks : Array Token) : Except String IClause := do + tks.mapM (ILit.ofTokenBounded bd) + +/-- Return a CNF computed from the tokens of a DIMACS CNF file, together with the variable count +stored in the header. -/ +def ICnf.ofLines (lns : Array (Array Token)) : Except String (ICnf × Nat) := do + let some hdr := lns[0]? + | throw s!"expected at least one line" + let #[.str "p", .str "cnf", nVars, .int nClauses] := hdr + | throw s!"unexpected header {hdr}" + let nVars ← Nat.ofToken nVars + let mut clauses : ICnf := #[] + for ln in lns[1:] do + try + let some (.int 0) := ln[ln.size - 1]? + | throw s!"missing terminating 0" + let lits := ln[:ln.size - 1] + let clause ← IClause.ofTokensBounded nVars lits + clauses := clauses.push clause + catch e => + throw s!"error on line '{" ".intercalate <| ln.toList.map toString}': {e}" + if Int.ofNat clauses.size ≠ nClauses then + throw s!"expected {nClauses} clauses, but got {clauses.size}" + return (clauses, nVars) + +def ICnf.readDimacsFile (fname : String) : IO (ICnf × Nat) := do + let lns ← IO.FS.lines fname + let lns := Dimacs.tokenizeLines lns + match ofLines lns with + | .ok v => return v + | .error e => throw <| IO.userError e + +def ICnf.toDimacs (cnf : ICnf) (nVars : Nat) : String := Id.run do + let mut s := s!"p cnf {nVars} {cnf.size}\n" + for C in cnf do + for l in C do + s := s ++ toString l ++ " " + s := s ++ "0\n" + return s + +/-- Return a proof step given a DIMACS line. -/ +def CpogStep.ofTokens (tks : Array Token) : Except String CpogStep := do + let toUpHints (tks : Array Token) : Except String (Array Nat) := do + if let #[.str "*"] := tks then + throw s!"got unhinted proof, but all hints need to be filled in" + tks.mapM Nat.ofToken + let (some fst, some snd) := (tks[0]?, tks[1]?) + | throw s!"expected at least two tokens" + let tks := tks[2:] + match fst, snd with + | idx, .str "a" => + let C := Array.takeWhile (· != Token.int 0) tks + let some (.int 0) := tks[C.size]? + | throw s!"missing terminating 0 in clause" + let some (.int 0) := tks[tks.size-1]? + | throw s!"missing terminating 0 in hints" + let hints : Subarray Token := tks[C.size+1:tks.size-1] + return .addAt (← Nat.ofToken idx) (← IClause.ofTokens C) (← toUpHints hints) + | .str "dc", idx => + let some (.int 0) := tks[tks.size-1]? + | throw s!"missing terminating 0 in hints" + let hints : Subarray Token := tks[:tks.size-1] + return .delAt (← Nat.ofToken idx) (← toUpHints hints) + | idx, .str "p" => + let some x := tks[0]? + | throw s!"missing product literal" + let some (.int 0) := tks[tks.size-1]? + | throw s!"missing terminating 0 in hints" + let ls : Subarray Token := tks[1:tks.size-1] + return .prod (← Nat.ofToken idx) (← Var.ofToken x) (← IClause.ofTokens ls) + | idx, .str "s" => + let (some x, some l₁, some l₂) := (tks[0]?, tks[1]?, tks[2]?) + | throw s!"missing sum parameters" + let some (.int 0) := tks[tks.size-1]? + | throw s!"missing terminating 0 in hints" + let hints : Subarray Token := tks[3:tks.size-1] + return .sum (← Nat.ofToken idx) (← Var.ofToken x) (← ILit.ofToken l₁) (← ILit.ofToken l₂) + (← toUpHints hints) + | .str "r", r => + return .root (← ILit.ofToken r) + | .str "do", _ => throw s!"do command is not supported" + | _, .str "i" => throw s!"i command is deprecated" + | _, _ => throw s!"unexpected command" + +def CpogStep.readDimacsFile (fname : String) : IO (Array CpogStep) := do + let lns ← IO.FS.lines fname + let lns := Dimacs.tokenizeLines lns + let mut pf := #[] + for ln in lns do + match CpogStep.ofTokens ln with + | .ok v => pf := pf.push v + | .error e => + throw <| IO.userError s!"error on line '{" ".intercalate <| ln.toList.map toString}': {e}" + return pf \ No newline at end of file diff --git a/Experiments/CPOG/Count/Pog.lean b/Experiments/CPOG/Count/Pog.lean new file mode 100644 index 0000000..1398209 --- /dev/null +++ b/Experiments/CPOG/Count/Pog.lean @@ -0,0 +1,344 @@ +/- +Copyright (c) 2023 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad +-/ + +import ProofChecker.Data.Pog +import ProofChecker.Count.PropForm + +open Nat +open PogElt + +namespace Pog + +/- +The count function +-/ + +-- This can be optimized to eliminate the first multiplication / division. +-- We can also avoid creating the array and compute the result with a loop. +def conjProd (nVars : Nat) {n : Nat} (g : Fin n → Nat) : Nat := + (Array.ofFn g).foldr (init := 2^nVars) (f := fun a b => a * b / 2^nVars) + +-- This shouldn't be used for computation, but we have more theorems about lists. +def conjProd' (nVars : Nat) {n : Nat} (g : Fin n → Nat) : Nat := + (List.ofFn g).foldr (init := 2^nVars) (f := fun a b => a * b / 2^nVars) + +theorem conjProd_eq_conjProd' : conjProd = conjProd' := by + ext nVars n f + rw [conjProd, conjProd', Array.foldr_eq_foldr_data, List.ofFn, Array.toList_eq] + +def toCountArray (pog : Pog) (nVars : Nat) : + { A : Array Nat // A.size = pog.elts.size } := + aux pog.elts.size #[] (by rw [add_comm]; rfl) +where + aux : (n : Nat) → (A : Array Nat) → (pog.elts.size = A.size + n) → + { A : Array Nat // A.size = pog.elts.size } + | 0, A, h => ⟨A, h.symm⟩ + | n + 1, A, h => + have ASizeLt : A.size < pog.elts.size := by + rw [h, ←add_assoc]; exact lt_succ_of_le (le_add_right _ _) + let nextElt : Nat := + match pog.elts[A.size]'ASizeLt, pog.wf ⟨A.size, ASizeLt⟩, pog.inv ⟨A.size, ASizeLt⟩ with + | var x, _, _ => 2^(nVars - 1) + | disj x left right, ⟨hleft, hright⟩, hinv => + have := lt_aux hleft hinv + have := lt_aux hright hinv + let lmodels := + if left.polarity then A[left.var.natPred] else 2^nVars - A[left.var.natPred] + let rmodels := + if right.polarity then A[right.var.natPred] else 2^nVars - A[right.var.natPred] + lmodels + rmodels + | conj n args, hwf, hinv => + conjProd nVars fun (j : Fin args.size) => + have := lt_aux (hwf j) hinv + if args[j].polarity then A[args[j].var.natPred] else 2^nVars - A[args[j].var.natPred] + aux n (A.push nextElt) (by rw [Array.size_push, h, add_assoc, add_comm 1]) + +def count (pog : Pog) (nVars : Nat) (x : Var) : Nat := + if h : x.natPred < pog.elts.size then + have : x.natPred < (pog.toCountArray nVars).1.size := by + rwa [(pog.toCountArray nVars).2] + (pog.toCountArray nVars).1[x.natPred] + else + PropForm.countModels nVars (ILit.mkPos x).toPropForm + +theorem countModels_foldr_conj (nVars : Nat) (φs : List (PropForm Var)) : + PropForm.countModels nVars (List.foldr PropForm.conj PropForm.tr φs) = + List.foldr (fun a b => a * b / 2 ^ nVars) (2 ^ nVars) + (φs.map (PropForm.countModels nVars)) := by + induction φs + . simp [PropForm.countModels] + . next φ φs ih => + rw [List.foldr_cons, PropForm.countModels, ih, List.map, List.foldr] + +theorem toCountArray_spec (pog : Pog) (nVars : Nat) : + ∀ i : Fin (pog.toCountArray nVars).1.size, + (pog.toCountArray nVars).1[i] = + PropForm.countModels nVars (pog.toPropForm (.mkPos (succPNat i))) := by + apply aux + rintro ⟨i, h⟩; contradiction +where + aux : (n : Nat) → (A : Array Nat) → (h : pog.elts.size = A.size + n) → + (h' : (∀ i : Fin A.size, A[i] = + PropForm.countModels nVars (pog.toPropForm (.mkPos (succPNat i))))) → + ∀ i : Fin (toCountArray.aux pog nVars n A h).1.size, + (toCountArray.aux pog nVars n A h).1[i] = + PropForm.countModels nVars (pog.toPropForm (.mkPos (succPNat i))) + | 0, _, _, h' => h' + | n + 1, A, h, h' => by + have ASizeLt : A.size < pog.elts.size := by + rw [h, ←add_assoc]; exact lt_succ_of_le (le_add_right _ _) + apply aux n; dsimp + intro ⟨i, i_lt⟩ + rw [Array.size_push] at i_lt + cases lt_or_eq_of_le (le_of_lt_succ i_lt) + next ilt => + rw [Array.get_push_lt _ _ i ilt] + exact h' ⟨i, ilt⟩ + next ieq => + simp only [ieq, Array.get_push_eq] + split + . next x _ hinv heq _ _ => + rw [toPropForm] + simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt] + rw [toPropForm_aux_eq, heq, PropForm.countModels] + . next x left right hleft hright hinv heq _ _ => + rw [toPropForm] + simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt] + have hleft : PNat.natPred (ILit.var left) < A.size := by + dsimp at hinv; rwa [hinv, PNat.natPred_lt_natPred] + have hright : PNat.natPred (ILit.var right) < A.size := by + dsimp at hinv; rwa [hinv, PNat.natPred_lt_natPred] + have hl := h' ⟨_, hleft⟩; dsimp at hl; rw [hl] + have hr := h' ⟨_, hright⟩; dsimp at hr; rw [hr] + rw [toPropForm_aux_eq, heq, PropForm.countModels, PNat.succPNat_natPred, + PNat.succPNat_natPred] + split + . next hlp => + rw [ILit.mkPos_var_true _ hlp] + split + . next hrp => + rw [ILit.mkPos_var_true _ hrp] + . next hrnp => + rw [Bool.not_eq_true] at hrnp + rw [ILit.mkPos_var_false _ hrnp, pog.toPropForm_of_polarity_eq_false _ hrnp, + PropForm.countModels] + . next hlnp => + rw [Bool.not_eq_true] at hlnp + rw [ILit.mkPos_var_false _ hlnp, pog.toPropForm_of_polarity_eq_false _ hlnp, + PropForm.countModels] + split + . next hrp => + rw [ILit.mkPos_var_true _ hrp] + . next hrnp => + rw [Bool.not_eq_true] at hrnp + rw [ILit.mkPos_var_false _ hrnp, pog.toPropForm_of_polarity_eq_false _ hrnp, + PropForm.countModels] + . next x args hwf hinv heq _ _ => + rw [toPropForm] + simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt] + rw [toPropForm_aux_eq, heq]; dsimp + rw [conjProd_eq_conjProd', conjProd', PropForm.arrayConj, PropForm.listConj, + countModels_foldr_conj] + apply congr_arg + rw [←Array.toList_eq, ←List.ofFn, List.map_ofFn] + apply congr_arg + ext j + simp only [Function.comp_apply] + simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt] + have harg : PNat.natPred (ILit.var args[j]) < A.size := by + dsimp at hinv; rw [hinv, PNat.natPred_lt_natPred] + exact hwf j + have ha := h' ⟨_, harg⟩; dsimp at ha; rw [ha] + rw [PNat.succPNat_natPred] + split + . next hlp => + rw [ILit.mkPos_var_true _ hlp] + . next hlnp => + rw [Bool.not_eq_true] at hlnp + rw [ILit.mkPos_var_false _ hlnp, pog.toPropForm_of_polarity_eq_false _ hlnp, + PropForm.countModels] + +theorem count_eq_countModels (pog : Pog) (nVars : Nat) (x : Var) : + pog.count nVars x = (pog.toPropForm (.mkPos x)).countModels nVars := by + rw [count, toPropForm, ILit.var_mkPos] + split + . next h => + have h' := h; rw [←(pog.toCountArray nVars).2] at h' + have := pog.toCountArray_spec nVars ⟨_, h'⟩ + dsimp at this; rw [PNat.succPNat_natPred] at this + dsimp; rw [this, toPropForm, ILit.var_mkPos, dif_pos h] + . next h => rfl + +theorem count_eq' (pog : Pog) (nVars : Nat) (x : Var) (φ : PropForm Var) : + pog.toPropForm (.mkPos x) = φ → + pog.count nVars x = φ.countModels nVars := by intro h; rw [←h, count_eq_countModels] + +/- +The ring evaluation function +-/ + +variable {R : Type} [CommRing R] + +def conjProdW {n : Nat} (g : Fin n → R) : R := + (Array.ofFn g).foldr (init := 1) (f := fun a b => a * b) + +def conjProdW' {n : Nat} (g : Fin n → R) : R := + (List.ofFn g).foldr (init := 1) (f := fun a b => a * b) + +theorem conjProdW_eq_conjProdW' : @conjProdW R _ = @conjProdW' R _ := by + apply funext; intro n + apply funext; intro g + rw [conjProdW, conjProdW', Array.foldr_eq_foldr_data, List.ofFn, Array.toList_eq] + +def toRingEvalArray (pog : Pog) (weight : Var → R) : + { A : Array R // A.size = pog.elts.size } := + aux pog.elts.size #[] (by rw [add_comm]; rfl) +where + aux : (n : Nat) → (A : Array R) → (pog.elts.size = A.size + n) → + { A : Array R // A.size = pog.elts.size } + | 0, A, h => ⟨A, h.symm⟩ + | n + 1, A, h => + have ASizeLt : A.size < pog.elts.size := by + rw [h, ←add_assoc]; exact lt_succ_of_le (le_add_right _ _) + let nextElt : R := + match pog.elts[A.size]'ASizeLt, pog.wf ⟨A.size, ASizeLt⟩, pog.inv ⟨A.size, ASizeLt⟩ with + | var x, _, _ => weight x + | disj x left right, ⟨hleft, hright⟩, hinv => + have := lt_aux hleft hinv + have := lt_aux hright hinv + let lmodels := + if left.polarity then A[left.var.natPred] else 1 - A[left.var.natPred] + let rmodels := + if right.polarity then A[right.var.natPred] else 1 - A[right.var.natPred] + lmodels + rmodels + | conj n args, hwf, hinv => + conjProdW fun (j : Fin args.size) => + have := lt_aux (hwf j) hinv + if args[j].polarity then A[args[j].var.natPred] else 1 - A[args[j].var.natPred] + aux n (A.push nextElt) (by rw [Array.size_push, h, add_assoc, add_comm 1]) + +def ringEval (pog : Pog) (weight : Var → R) (x : Var) : R := + if h : x.natPred < pog.elts.size then + have : x.natPred < (pog.toRingEvalArray weight).1.size := by + rwa [(pog.toRingEvalArray weight).2] + (pog.toRingEvalArray weight).1[x.natPred] + else + PropForm.ringEval weight (ILit.mkPos x).toPropForm + +theorem ringEval_foldr_conj (weight : Var → R) (φs : List (PropForm Var)) : + PropForm.ringEval weight (List.foldr PropForm.conj PropForm.tr φs) = + List.foldr (fun a b => a * b) 1 + (φs.map (PropForm.ringEval weight)) := by + induction φs + . simp [PropForm.ringEval] + . next φ φs ih => + rw [List.foldr_cons, PropForm.ringEval, ih, List.map, List.foldr] + +theorem toRingEvalArray_spec (pog : Pog) (weight : Var → R) : + ∀ i : Fin (pog.toRingEvalArray weight).1.size, + (pog.toRingEvalArray weight).1[i] = + PropForm.ringEval weight (pog.toPropForm (.mkPos (succPNat i))) := by + apply aux + rintro ⟨i, h⟩; contradiction +where + aux : (n : Nat) → (A : Array R) → (h : pog.elts.size = A.size + n) → + (h' : (∀ i : Fin A.size, A[i] = + PropForm.ringEval weight (pog.toPropForm (.mkPos (succPNat i))))) → + ∀ i : Fin (Pog.toRingEvalArray.aux pog weight n A h).1.size, + (Pog.toRingEvalArray.aux pog weight n A h).1[i] = + PropForm.ringEval weight (pog.toPropForm (.mkPos (succPNat i))) + | 0, _, _, h' => h' + | n + 1, A, h, h' => by + have ASizeLt : A.size < pog.elts.size := by + rw [h, ←add_assoc]; exact lt_succ_of_le (le_add_right _ _) + apply aux n; dsimp + intro ⟨i, i_lt⟩ + rw [Array.size_push] at i_lt + cases lt_or_eq_of_le (le_of_lt_succ i_lt) + next ilt => + rw [Array.get_push_lt _ _ i ilt] + exact h' ⟨i, ilt⟩ + next ieq => + simp only [ieq, Array.get_push_eq] + split + . next x _ hinv heq _ _ => + rw [toPropForm] + simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt] + rw [toPropForm_aux_eq, heq, PropForm.ringEval] + . next x left right hleft hright hinv heq _ _ => + rw [toPropForm] + simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt] + have hleft : PNat.natPred (ILit.var left) < A.size := by + dsimp at hinv; rwa [hinv, PNat.natPred_lt_natPred] + have hright : PNat.natPred (ILit.var right) < A.size := by + dsimp at hinv; rwa [hinv, PNat.natPred_lt_natPred] + have hl := h' ⟨_, hleft⟩; dsimp at hl; rw [hl] + have hr := h' ⟨_, hright⟩; dsimp at hr; rw [hr] + rw [toPropForm_aux_eq, heq, PropForm.ringEval, PNat.succPNat_natPred, + PNat.succPNat_natPred] + split + . next hlp => + rw [ILit.mkPos_var_true _ hlp] + split + . next hrp => + rw [ILit.mkPos_var_true _ hrp] + . next hrnp => + rw [Bool.not_eq_true] at hrnp + rw [ILit.mkPos_var_false _ hrnp, pog.toPropForm_of_polarity_eq_false _ hrnp, + PropForm.ringEval] + . next hlnp => + rw [Bool.not_eq_true] at hlnp + rw [ILit.mkPos_var_false _ hlnp, pog.toPropForm_of_polarity_eq_false _ hlnp, + PropForm.ringEval] + split + . next hrp => + rw [ILit.mkPos_var_true _ hrp] + . next hrnp => + rw [Bool.not_eq_true] at hrnp + rw [ILit.mkPos_var_false _ hrnp, pog.toPropForm_of_polarity_eq_false _ hrnp, + PropForm.ringEval] + . next x args hwf hinv heq _ _ => + rw [toPropForm] + simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt] + rw [toPropForm_aux_eq, heq]; dsimp + rw [conjProdW_eq_conjProdW', conjProdW', PropForm.arrayConj, PropForm.listConj, + ringEval_foldr_conj] + apply congr_arg + rw [←Array.toList_eq, ←List.ofFn, List.map_ofFn] + apply congr_arg + apply funext; intro j + simp only [Function.comp_apply] + simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt] + have harg : PNat.natPred (ILit.var args[j]) < A.size := by + dsimp at hinv; rw [hinv, PNat.natPred_lt_natPred] + exact hwf j + have ha := h' ⟨_, harg⟩; dsimp at ha; rw [ha] + rw [PNat.succPNat_natPred] + split + . next hlp => + rw [ILit.mkPos_var_true _ hlp] + . next hlnp => + rw [Bool.not_eq_true] at hlnp + rw [ILit.mkPos_var_false _ hlnp, pog.toPropForm_of_polarity_eq_false _ hlnp, + PropForm.ringEval] + +theorem ringEval_eq_ringEval (pog : Pog) (weight : Var → R) (x : Var) : + pog.ringEval weight x = (pog.toPropForm (.mkPos x)).ringEval weight := by + rw [ringEval, toPropForm, ILit.var_mkPos] + split + . next h => + have h' := h; rw [←(pog.toRingEvalArray weight).2] at h' + have := pog.toRingEvalArray_spec weight ⟨_, h'⟩ + dsimp at this; rw [PNat.succPNat_natPred] at this + dsimp; rw [this, toPropForm, ILit.var_mkPos, dif_pos h] + . next h => rfl + +theorem ringEval_eq' (pog : Pog) (weight : Var → R) (x : Var) (φ : PropForm Var) : + pog.toPropForm (.mkPos x) = φ → + pog.ringEval weight x = φ.ringEval weight := by + intro h; rw [←h, ringEval_eq_ringEval] + +end Pog diff --git a/Experiments/CPOG/Count/PropForm.lean b/Experiments/CPOG/Count/PropForm.lean new file mode 100644 index 0000000..1f6a86b --- /dev/null +++ b/Experiments/CPOG/Count/PropForm.lean @@ -0,0 +1,581 @@ +/- +Copyright (c) 2023 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad +-/ + +import Mathlib.Data.Finset.Powerset +import Mathlib.Data.Finset.Card +import Mathlib.Algebra.BigOperators.Ring +import ProofChecker.Data.Pog + +open Finset + +/- +This is the counting function for partitioned formulas, also known as POGs. The main theorem, +to be proved below, is that this really does count the number of models. +-/ + +namespace PropForm + +def countModels (nVars : Nat) : PropForm ν → Nat + | tr => 2^nVars + | fls => 0 + | var _ => 2^(nVars - 1) + | neg φ => 2^nVars - φ.countModels nVars + | disj φ ψ => φ.countModels nVars + ψ.countModels nVars + | conj φ ψ => φ.countModels nVars * ψ.countModels nVars / 2^nVars + | impl _ _ => 0 + | biImpl _ _ => 0 + +def ringEval {R : Type} [CommRing R] (weight : ν → R) : PropForm ν → R + | tr => 1 + | fls => 0 + | var x => weight x + | neg φ => 1 - φ.ringEval weight + | disj φ ψ => φ.ringEval weight + ψ.ringEval weight + | conj φ ψ => φ.ringEval weight * ψ.ringEval weight + | impl _ _ => 0 + | biImpl _ _ => 0 + +end PropForm + +/- +Propositional assignments and their restrictions to finsets. +-/ + +namespace PropAssignment + +def defined_on (v : PropAssignment ν) (s : Finset ν) : Prop := ∀ ⦃x⦄, x ∉ s → v x = false + +theorem eq_false_of_defined_on {v : PropAssignment ν} {s : Finset ν} {x : ν} + (h : v.defined_on s) (h' : ¬ x ∈ s) : v x = false := h h' + +theorem defined_on_mono {v : PropAssignment ν} {s t : Finset ν} (h : s ⊆ t) : + v.defined_on s → v.defined_on t := + fun h' _ hnnt => h' fun hns => hnnt (h hns) + +variable [DecidableEq ν] + +def restrict (v : PropAssignment ν) (s : Finset ν) : PropAssignment ν := fun x => if x ∈ s then v x else false + +@[simp] theorem defined_on_restrict (v : PropAssignment ν) (s : Finset ν) : + (v.restrict s).defined_on s := by intro n hns; rw [restrict, if_neg hns] + +@[simp] theorem restrict_pos (v : PropAssignment ν) {x : ν} {s : Finset ν} (h : x ∈ s) : + v.restrict s x = v x := by simp [restrict, h] + +end PropAssignment + +namespace PropForm + +variable [DecidableEq ν] + +theorem eval_restrict_vars (φ : PropForm ν) (v : PropAssignment ν) : + φ.eval (v.restrict φ.vars) = φ.eval v := + eval_ext fun _ hx => v.restrict_pos hx + +end PropForm + +namespace Finset + +variable [DecidableEq ν] + +/-- The characteristic funbction of `s`. -/ +def toPropAssignment (s : Finset ν) : PropAssignment ν := fun x => if x ∈ s then true else false + +theorem toPropAssignment_eq_true {x : ν} (s : Finset ν) : + s.toPropAssignment x = true ↔ x ∈ s := by + rw [toPropAssignment]; split <;> simp_all + +theorem toPropAssignment_eq_false {x : ν} (s : Finset ν) : + s.toPropAssignment x = false ↔ x ∉ s := by + simp [←toPropAssignment_eq_true] + +theorem injective_toPropAssignment : Function.Injective (@toPropAssignment ν _) := by + intro s1 s2 heq + ext x + have := congr_fun heq x + rw [←s1.toPropAssignment_eq_true, this, s2.toPropAssignment_eq_true] + +end Finset + +/- +Models of a propositional formula over a set of variables. + +Note: we don't intend to use this theory computationally, so we use classical logic to declare +decidable equality on `PropAssignment ν`. +-/ + +variable [DecidableEq ν] + +noncomputable instance : DecidableEq (PropAssignment ν) := fun _ _ => Classical.propDecidable _ + +namespace Finset + +noncomputable def assignments (s : Finset ν) : Finset (PropAssignment ν) := + s.powerset.image toPropAssignment + +@[simp] theorem mem_assignments (s : Finset ν) (v : PropAssignment ν) : + v ∈ assignments s ↔ v.defined_on s := by + simp only [assignments, mem_image, mem_powerset] + constructor + . rintro ⟨t, ht1, rfl⟩ x hx + rw [toPropAssignment_eq_false] + intro h; exact hx (ht1 h) + . intro h + use s.filter (v . = true) + simp only [filter_subset, true_and] + ext x + simp only [toPropAssignment, mem_filter] + by_cases hx : x ∈ s + . cases (v x) <;> simp [hx] + . simp [hx, h hx] + +theorem InjOn_set_assignments (s : Finset ν) (hxs : x ∉ s) (b : Bool) : + Set.InjOn (PropAssignment.set . x b) (assignments s) := by + intro v1 hv1 v2 hv2 heq + simp only [mem_coe, mem_assignments] at hv1 hv2 + ext x' + have := congr_fun heq x'; dsimp at this + by_cases h : x' = x + . rw [h, hv1 hxs, hv2 hxs] + . rwa [PropAssignment.set_get_of_ne _ _ (Ne.symm h), + PropAssignment.set_get_of_ne _ _ (Ne.symm h)] at this + +theorem assignments_empty : assignments (∅ : Finset ν) = {fun _ => false} := by + ext τ; simp only [mem_assignments, PropAssignment.defined_on, not_mem_empty, not_false_iff, + forall_true_left, mem_singleton] + constructor + . intro h; ext x; simp [h] + . intro h; simp [h] + +theorem card_assignments (s : Finset ν) : card (assignments s) = 2^(card s) := by + rw [assignments, card_image_of_injective _ injective_toPropAssignment, card_powerset] + +end Finset + +def PropAssignment.cond (s : Finset ν) (p : PropAssignment ν × PropAssignment ν) : + PropAssignment ν := + fun x => if x ∈ s then p.1 x else p.2 x + +namespace PropForm + +/-- Models of a propositional formula on a set of variables -/ +noncomputable def models (φ : PropForm ν) (s : Finset ν) := s.assignments.filter (φ.eval .) + +@[simp] theorem mem_models {φ : PropForm ν} {s : Finset ν} (v : PropAssignment ν) : + v ∈ φ.models s ↔ v.defined_on s ∧ φ.eval v = true := + by rw [models, mem_filter, mem_assignments] + +theorem models_tr (s : Finset ν) : tr.models s = assignments s := by + simp [models] + +theorem models_fls (s : Finset ν) : fls.models s = (∅ : Finset (PropAssignment ν)) := by + ext τ; simp + +theorem models_disj {φ ψ : PropForm ν} (s : Finset ν) : + (φ.disj ψ).models s = (φ.models s) ∪ (ψ.models s) := by + ext v; simp [mem_models, eval, and_or_left] + +theorem models_Disjoint {φ ψ : PropForm ν} (s : Finset ν) (h : ∀ v, ¬ (φ.eval v ∧ ψ.eval v)) : + Disjoint (φ.models s) (ψ.models s) := by + rw [disjoint_iff_ne] + rintro v hv1 _ hv2 rfl + apply h v + rw [mem_models] at hv1 hv2 + rw [hv1.2, hv2.2]; simp + +theorem models_var {x : ν} {s : Finset ν} (hxs : x ∈ s) : + (var x).models s = (assignments (s.erase x)).image (PropAssignment.set . x true) := by + ext v; simp only [mem_models, eval, mem_image] + constructor + . intro ⟨hvdef, hvx⟩ + use v.set x false + constructor + . rw [mem_assignments] + intro x' hx' + rw [mem_erase, not_and] at hx' + by_cases h : x' = x + . rw [h, PropAssignment.set_get] + . rw [PropAssignment.set_get_of_ne _ _ (Ne.symm h), hvdef (hx' h)] + . rw [PropAssignment.set_set, ←hvx, PropAssignment.set_same] + . rintro ⟨v', hv', rfl⟩ + rw [mem_assignments] at hv' + constructor + . intro x' hx' + have h1 : x' ≠ x := by rintro rfl; contradiction + have h2 : x' ∉ erase s x := by rw [mem_erase, not_and_or]; right; exact hx' + rw [PropAssignment.set_get_of_ne _ _ (Ne.symm h1), hv' h2] + . simp + +theorem models_neg (φ : PropForm ν) (s : Finset ν) : + φ.neg.models s ∪ φ.models s = assignments s := by + ext v; simp only [mem_assignments, mem_union, mem_models, eval, Bool.bnot_eq_to_not_eq, + Bool.not_eq_true] + rw [←and_or_left]; cases (eval v φ) <;> simp + +theorem models_neg_Disjoint (φ : PropForm ν) (s : Finset ν) : + Disjoint (φ.neg.models s) (φ.models s) := by + rw [disjoint_iff_ne] + rintro v hv1 _ hv2 rfl + rw [mem_models] at hv2 + rw [mem_models, eval, hv2.2] at hv1 + simp at hv1 + +theorem models_conj {φ ψ: PropForm ν} (hdisj : φ.vars ∩ ψ.vars = ∅) : + (φ.conj ψ).models ((φ.conj ψ).vars) = + ((φ.models φ.vars).product (ψ.models ψ.vars)).image (PropAssignment.cond φ.vars) := by + symm; ext v + simp only [mem_image, mem_product, mem_models, Prod.exists, eval, Bool.and_eq_true, + PropAssignment.cond, vars] + constructor + . rintro ⟨v1, v2, ⟨⟨_, heval1⟩, ⟨hdef2, heval2⟩⟩, rfl⟩ + constructor + . intro x hx + rw [mem_union, not_or] at hx + dsimp; rw [if_neg hx.1, hdef2 hx.2] + . constructor + . rw [←heval1]; apply eval_ext + intro x hx; rw [if_pos hx] + . rw [←heval2]; apply eval_ext + intro x hx + simp only [eq_empty_iff_forall_not_mem, mem_inter, not_and'] at hdisj + have hx' : x ∉ φ.vars := hdisj _ hx + rw [if_neg hx'] + . intro ⟨hdef, heval1, heval2⟩ + use fun x => if x ∈ φ.vars then v x else false + use fun x => if x ∈ ψ.vars then v x else false + dsimp + constructor + . constructor + . constructor + . intro x hx; dsimp; rw [if_neg hx] + . rw [←heval1] + apply eval_ext; intro x hx; rw [if_pos hx] + . constructor + . intro x hx; dsimp; rw [if_neg hx] + . rw [←heval2] + apply eval_ext; intro x hx; rw [if_pos hx] + . ext x + have := @hdef x + split <;> simp_all + +theorem InjOn_cond (φ ψ : PropForm ν) {s t : Finset ν} (hdisj : s ∩ t = ∅) : + Set.InjOn (PropAssignment.cond s) <| (φ.models s).product (ψ.models t) := by + intro ⟨p11, p12⟩ hp1 ⟨p21, p22⟩ hp2 + simp only [coe_product, Set.mem_prod, mem_coe, mem_models] at hp1 hp2 + simp only [PropAssignment.cond] + dsimp; intro h + rw [Prod.mk.injEq] + constructor + . ext x + have := congr_fun h x + by_cases h' : x ∈ s <;> simp_all + rw [hp1.1.1 h', hp2.1.1 h'] + . ext x + have := congr_fun h x + by_cases h' : x ∈ s <;> simp_all + simp only [eq_empty_iff_forall_not_mem, mem_inter, not_and] at hdisj + rw [hp1.2.1 (hdisj _ h'), hp2.2.1 (hdisj _ h')] + +theorem models_insert {φ : PropForm ν} {a : ν} {s : Finset ν} (h : φ.vars ⊆ s) (ha : a ∉ s) : + φ.models (insert a s) = φ.models s ∪ (φ.models s).image (fun τ => τ.set a true) := by + ext τ + simp only [mem_models, mem_union, mem_image] + constructor + . intro ⟨hdef, heq⟩ + by_cases h' : τ a = true + . right + use (τ.set a false) + constructor + . constructor + . intro x xns + by_cases hx : x = a + . rw [hx, PropAssignment.set_get] + . rw [PropAssignment.set_get_of_ne _ _ (Ne.symm hx)] + apply hdef; simp [xns, hx] + . rw [eval_set_of_not_mem_vars, heq] + intro h''; exact ha (h h'') + . rw [PropAssignment.set_set, ←h', PropAssignment.set_same] + . left; rw [Bool.not_eq_true] at h' + constructor + . intro x xns + by_cases hx : x = a + . rw [hx, h'] + . apply hdef; simp [xns, hx] + . exact heq + . rintro (⟨hdef, heq⟩ | ⟨τ', ⟨hdef, heval⟩, rfl⟩) + . exact ⟨PropAssignment.defined_on_mono (Finset.subset_insert _ _) hdef, heq⟩ + . constructor + . intro x xnas + rw [mem_insert, not_or] at xnas + rw [PropAssignment.set_get_of_ne _ _ (Ne.symm xnas.1)] + exact hdef xnas.2 + . rw [←heval] + apply eval_ext + intro x hx + rw [PropAssignment.set_get_of_ne] + contrapose! ha; rw [ha] + exact h hx + +theorem models_insert_Disjoint {φ : PropForm ν} {a : ν} {s : Finset ν} (ha : a ∉ s) : + Disjoint (φ.models s) ((φ.models s).image (fun τ => τ.set a true)) := by + rw [disjoint_iff_ne] + rintro τ hτ1 _ hτ2 rfl + simp only [mem_image, mem_models] at hτ1 hτ2 + rcases hτ2 with ⟨τ', ⟨⟨_, _⟩, rfl⟩⟩ + have := hτ1.1 + specialize this ha + rw [PropAssignment.set_get] at this + contradiction + +/- +Theorems about cardinality. +-/ + +@[simp] theorem card_models_tr (s : Finset ν) : card ((tr : PropForm ν).models s) = 2^(card s) := by + simp [models_tr, card_assignments] + +@[simp] theorem card_models_fls (s : Finset ν) : card ((fls : PropForm ν).models s) = 0 := by + simp [models_fls, card_assignments] + +@[simp] theorem card_models_var {x : ν} {s : Finset ν} (hxs : x ∈ s) : + card ((var x).models s) = 2^(card s - 1) := by + rw [models_var hxs, + card_image_of_injOn (Finset.InjOn_set_assignments _ (Finset.not_mem_erase _ _) _), + card_assignments, card_erase_of_mem hxs] + +@[simp] theorem card_models_disj_disjoint {φ ψ : PropForm ν} (s : Finset ν) + (h : ∀ v, ¬ (φ.eval v ∧ ψ.eval v)) : + card ((φ.disj ψ).models s) = card (φ.models s) + card (ψ.models s) := by + rw [models_disj, card_disjoint_union (models_Disjoint _ h)] + +@[simp] theorem card_models_neg (φ : PropForm ν) (s : Finset ν) : + card (φ.neg.models s) = 2^(card s) - card (φ.models s) := by + symm; apply Nat.sub_eq_of_eq_add + rw [←card_disjoint_union (models_neg_Disjoint _ _), models_neg, card_assignments] + +theorem card_models_vars {φ : PropForm ν} {s : Finset ν} (h : φ.vars ⊆ s) : + card (φ.models s) = card (φ.models φ.vars) * 2^(card s - card φ.vars) := by + let f (p : PropAssignment ν × Finset ν) : PropAssignment ν := + fun x => if x ∈ φ.vars then p.1 x else p.2.toPropAssignment x + have h1 : ((φ.models φ.vars).product (s \ φ.vars).powerset).image f = φ.models s := by + ext v; simp only [mem_image, mem_product, mem_models, mem_powerset, Prod.exists] + constructor + { rintro ⟨v, t, ⟨⟨_, hevalv⟩, hh⟩, rfl⟩ + constructor + . intro x hxns + have : x ∉ φ.vars := fun h' => hxns (h h') + dsimp; rw [if_neg this, toPropAssignment_eq_false] + intro h'; apply hxns; exact subset_sdiff.mp hh |>.1 h' + . rw [←hevalv] + apply eval_ext + intro x hx + rw [if_pos hx] } + intro ⟨hvdef, hevalv⟩ + use v.restrict φ.vars, (s \ φ.vars).filter (fun x => v x) + constructor + . constructor + . constructor + . simp + . rw [eval_restrict_vars, hevalv] + . apply filter_subset + . ext x; dsimp; split + . next h => rw [v.restrict_pos h] + . next hmem => + unfold Finset.toPropAssignment + by_cases hxs : x ∈ s <;> split <;> simp_all [@hvdef x] + have h2 : Set.InjOn f <| (φ.models φ.vars).product (s \ φ.vars).powerset := by + intro ⟨v1, t1⟩ h21 ⟨v2, t2⟩ h22 h23 + simp only [Set.mem_prod, mem_product, mem_coe, mem_models, Set.mem_preimage, mem_powerset, + and_imp, subset_sdiff, Prod.forall, Prod.mk.injEq] at h21 h22 h23 |- + constructor + . ext x + by_cases hx : x ∈ φ.vars + . have := congr_fun h23 x + simp [hx] at this; exact this + . rw [h21.1.1 hx, h22.1.1 hx] + . ext x + simp at h21 + by_cases hx : x ∈ φ.vars + . rw [eq_false (disjoint_right.mp h21.2.2 hx), eq_false (disjoint_right.mp h22.2.2 hx)] + . have := congr_fun h23 x + simp [hx] at this + rw [←toPropAssignment_eq_true, this, toPropAssignment_eq_true] + rw [←h1, card_image_of_injOn h2, card_product, card_powerset, card_sdiff h] + +theorem card_models_conj_aux {φ ψ: PropForm ν} (hdisj : φ.vars ∩ ψ.vars = ∅) : + card ((φ.conj ψ).models (φ.conj ψ).vars) = + card (φ.models φ.vars) * card (ψ.models ψ.vars) := by + rw [models_conj hdisj, card_image_of_injOn (InjOn_cond _ _ hdisj), card_product] + +@[simp] theorem card_models_conj {φ ψ : PropForm ν} {s : Finset ν} + (hsub : φ.vars ∪ ψ.vars ⊆ s) (hdisj : vars φ ∩ vars ψ = ∅) : + card ((φ.conj ψ).models s) = card (φ.models s) * card (ψ.models s) / 2^(card s):= by + symm; apply Nat.div_eq_of_eq_mul_left + . apply pow_pos; apply zero_lt_two + have hφ := union_subset_left hsub + have hψ := union_subset_right hsub + have card_un := card_disjoint_union (disjoint_iff_inter_eq_empty.mpr hdisj) + have aux : card (vars ψ) ≤ card s - card (vars φ) := by + apply Nat.le_sub_of_add_le + rw [add_comm, ←card_un] + exact card_le_of_subset hsub + have : (φ.conj ψ).vars ⊆ s := by rw [vars, union_subset_iff]; exact ⟨hφ, hψ⟩ + rw [card_models_vars hφ, card_models_vars hψ, card_models_vars this, card_models_conj_aux hdisj] + rw [mul_right_comm]; simp only [mul_assoc, ←pow_add] + rw [←Nat.sub_add_comm (card_le_of_subset hψ)] + rw [Nat.add_sub_assoc aux, add_comm (card s)] + rw [vars, card_un, tsub_tsub] + +/- +The main theorem. +-/ + +theorem countModels_eq_card_models {φ : PropForm ν} {s : Finset ν} + (hvars : φ.vars ⊆ s) (hdec : φ.partitioned) : + φ.countModels s.card = card (φ.models s) := by + induction φ + case var x => + rw [vars, singleton_subset_iff] at hvars + rw [countModels, card_models_var hvars] + case tr => simp [countModels] + case fls => simp [countModels] + case neg φ ih => + rw [vars] at hvars + rw [partitioned] at hdec + rw [countModels, card_models_neg φ, ih hvars hdec] + case conj φ ψ ihφ ihψ => + rw [vars] at hvars + have hφ := union_subset_left hvars + have hψ := union_subset_right hvars + rw [partitioned] at hdec + rw [countModels, card_models_conj hvars hdec.2.2, ihφ hφ hdec.1, ihψ hψ hdec.2.1] + case disj φ ψ ihφ ihψ => + rw [vars, union_subset_iff] at hvars + rw [partitioned] at hdec + rw [countModels, card_models_disj_disjoint s hdec.2.2, ihφ hvars.1 hdec.1, ihψ hvars.2 hdec.2.1] + case impl _ => rw [partitioned] at hdec; contradiction + case biImpl _ _ => rw [partitioned] at hdec; contradiction + +end PropForm + +/- +Weighted models +-/ + +namespace PropForm + +variable {R : Type} [CommRing R] + +open BigOperators + +noncomputable def weightSum (weight : ν → R) (φ : PropForm ν) (s : Finset ν) : R := + ∑ τ in φ.models s, ∏ x in s, if τ x then weight x else 1 - weight x + +theorem injective_models_set {φ : PropForm ν} {a : ν} {s : Finset ν} {b : Bool} (h' : a ∉ s) : + ∀ x ∈ models φ s, ∀ y ∈ models φ s, + PropAssignment.set x a b = PropAssignment.set y a b → x = y := by + simp only [mem_models] + intro τ1 ⟨τ1def, _⟩ τ2 ⟨τ2def, _⟩ heq + ext x + have := congr_fun heq x + by_cases h : a = x + . rw [←h, τ1def h', τ2def h'] + . simp [PropAssignment.set_get_of_ne _ _ h] at this + exact this + +theorem weightSum_insert (weight : ν → R) {φ : PropForm ν} {a : ν} {s : Finset ν} + (h : φ.vars ⊆ s) (h' : a ∉ s) : + weightSum weight φ (insert a s) = weightSum weight φ s := by + rw [weightSum, models_insert h h', Finset.sum_union (models_insert_Disjoint h')] + rw [Finset.sum_image (injective_models_set h'), ←Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro τ hτ; rw [mem_models] at hτ + rw [Finset.prod_insert h', Finset.prod_insert h']; dsimp + have : τ a ≠ true := by rw [hτ.1 h']; simp + rw [if_neg this, PropAssignment.set_get, if_pos rfl] + have : ∀ x, x = (1 - weight a) * x + weight a * x := + by intro x; rw [←add_mul, sub_add_cancel, one_mul] + symm; trans; apply this + apply congr_arg; apply congr_arg; apply Finset.prod_congr rfl + intro x xs; rw [PropAssignment.set_get_of_ne]; rintro rfl; exact h' xs + +theorem weightSum_of_vars_subset (weight : ν → R) {φ : PropForm ν} {s : Finset ν} + (h : φ.vars ⊆ s) : weightSum weight φ s = weightSum weight φ φ.vars := by + suffices : ∀ t, φ.vars ∩ t = ∅ → weightSum weight φ φ.vars = weightSum weight φ (φ.vars ∪ t) + . specialize this (s \ φ.vars) (Finset.inter_sdiff_self _ _) + rw [this, Finset.union_sdiff_of_subset h] + intro t + induction t using Finset.induction + . next => simp + . next a t anint ih => + intro hdisj + rw [weightSum, Finset.union_insert, weightSum_insert, ←ih]; rfl + . rw [←subset_empty, ←hdisj]; apply inter_subset_inter_left + apply subset_insert + . apply subset_union_left + rw [mem_union, not_or] + refine ⟨?_, anint⟩ + intro ha + apply not_mem_empty a + rw [←hdisj, mem_inter] + exact ⟨ha, mem_insert_self _ _⟩ + +theorem ringEval_eq_weightSum (weight : ν → R) {φ : PropForm ν} (hdec : φ.partitioned) : + φ.ringEval weight = φ.weightSum weight φ.vars := by + have weightSum_tr : weightSum weight tr (vars tr) = 1 := by + rw [weightSum, models_tr, vars, assignments_empty, sum_singleton, prod_empty] + induction φ + case var x => + rw [ringEval, weightSum, vars, models_var (mem_singleton_self x), erase_singleton, + assignments_empty, image_singleton, sum_singleton, prod_singleton, + PropAssignment.set_get, if_pos rfl] + case tr => + rw [ringEval, weightSum_tr] + case fls => + rw [ringEval, weightSum, models_fls, sum_empty] + case neg φ ih => + rw [partitioned] at hdec + rw [ringEval, ih hdec, sub_eq_iff_eq_add, vars, weightSum, weightSum, + ←sum_union (models_neg_Disjoint _ _), models_neg, ←models_tr, ←weightSum, + weightSum_of_vars_subset, weightSum_tr] + simp [vars] + case conj φ ψ ihφ ihψ => + rw [partitioned] at hdec + have hDisj : Disjoint φ.vars ψ.vars := by + rw [disjoint_iff_inter_eq_empty]; exact hdec.2.2 + rw [ringEval, weightSum, models_conj hdec.2.2, ihφ hdec.1, ihψ hdec.2.1, + sum_image (InjOn_cond _ _ hdec.2.2), sum_product, weightSum, mul_comm, + mul_sum] + apply sum_congr rfl + intros τ _ + rw [mul_comm, weightSum, mul_sum] + apply sum_congr rfl + intros τ' _ + rw [vars, prod_union hDisj] + apply congr; apply congr_arg + . apply prod_congr rfl + intros x hx; simp [hx, PropAssignment.cond] + . apply prod_congr rfl + intros x hx + have hx' : x ∉ φ.vars := by + intro h + apply not_mem_empty x + rw [←hdec.2.2, mem_inter] + exact ⟨h, hx⟩ + simp [hx', PropAssignment.cond] + case disj φ ψ ihφ ihψ => + rw [partitioned] at hdec + have h1 : vars φ ⊆ vars (φ.disj ψ) := subset_union_left _ _ + have h2 : vars ψ ⊆ vars (φ.disj ψ) := subset_union_right _ _ + rw [ringEval, ihφ hdec.1, ihψ hdec.2.1, ←weightSum_of_vars_subset _ h1, + ←weightSum_of_vars_subset _ h2] + unfold weightSum + rw [models_disj, sum_union (models_Disjoint _ hdec.2.2)] + case impl _ => rw [partitioned] at hdec; contradiction + case biImpl _ _ => rw [partitioned] at hdec; contradiction + +end PropForm + diff --git a/Experiments/CPOG/Data/ClauseDb.lean b/Experiments/CPOG/Data/ClauseDb.lean new file mode 100644 index 0000000..31d9f3e --- /dev/null +++ b/Experiments/CPOG/Data/ClauseDb.lean @@ -0,0 +1,612 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import ProofChecker.Model.PropForm +import ProofChecker.Model.PropVars + +import ProofChecker.Data.HashMap.Lemmas +import ProofChecker.Data.ICnf + +/-! Clause database together with some (provably correct) methods. For example, we can conclude +that if a clause follows from the current database by unit propagation, then it is implied by the +database's interpretation as a propositional formula. -/ + +/-- A stateful clause database, i.e. a dynamically modifiable CNF, for use in poly-time proof +checkers such as for LRAT. It uses in-place data structures, so should be used linearly. + +(Persistent structures do not seem immediately helpful as linear formats do not backtrack.) + +In `ClauseDb α`, `α` is the type of clause indices. -/ +structure ClauseDb (α : Type) [BEq α] [Hashable α] where + /-- Each clause is stored together with a flag indicating whether it has been deleted. + Deleted clauses are logically not in the database. -/ + clauses : HashMap α (IClause × Bool) := {} + +namespace HashMap + +variable [BEq α] [Hashable α] + +def mapOne (m : HashMap α β) (idx : α) (f : β → β) : HashMap α β := + match m.find? idx with + | some b => m.insert idx (f b) + | none => m + +end HashMap + +inductive UnitPropResult (α : Type) where + | contradiction + /-- The hint did not become unit. -/ + | hintNotUnit (hint : α) + /-- The hint points at a nonexistent clause. -/ + | hintNonexistent (hint : α) + | extended (τ : PartPropAssignment) + +namespace UnitPropResult + +def isContradiction (r : UnitPropResult α) : Bool := + r matches contradiction + +end UnitPropResult + +namespace ClauseDb + +variable {α : Type} [BEq α] [Hashable α] + +instance [ToString α] : ToString (ClauseDb α) where + toString db := toString db.clauses.toList + +def empty : ClauseDb α := { clauses := .empty } + +def fold (db : ClauseDb α) (f : β → α → IClause → β) (init : β) : β := + db.clauses.fold (init := init) fun acc idx (C, deleted) => + if deleted then acc else f acc idx C + +def foldM [Monad m] (db : ClauseDb α) (f : β → α → IClause → m β) (init : β) : m β := + db.clauses.foldM (init := init) fun acc idx (C, deleted) => + if deleted then pure acc else f acc idx C + +def addClause (db : ClauseDb α) (idx : α) (C : IClause) : ClauseDb α := + { db with clauses := db.clauses.insert idx (C, false) } + +def delClause (db : ClauseDb α) (idx : α) : ClauseDb α := + { db with clauses := db.clauses.mapOne idx fun (C, _) => (C, true) } + +def getClause (db : ClauseDb α) (idx : α) : Option IClause := + db.clauses.find? idx |>.bind (fun (C, deleted) => if deleted then none else C) + +def contains (db : ClauseDb α) (idx : α) : Bool := + db.getClause idx |>.isSome + +/-- NOTE: This implementation is not efficient as it doesn't use early return. -/ +def all (db : ClauseDb α) (p : α → IClause → Bool) : Bool := + db.fold (fun acc idx C => acc && p idx C) true + +/-- NOTE: This implementation is not efficient as it doesn't use early return. -/ +def any (db : ClauseDb α) (p : α → IClause → Bool) : Bool := + !db.all (fun idx C => !p idx C) + +/-- Initialize a clause database from a CNF array. -/ +def ofICnf (cnf : ICnf) : ClauseDb Nat := + let (db, _) := cnf.foldl (init := (empty, 1)) fun (db, idx) C => + (db.addClause idx C, idx + 1) + db + +@[deprecated] +def unitPropWithHints (db : ClauseDb α) (τ : PartPropAssignment) (hints : Array α) + : UnitPropResult α := Id.run do + let mut τ := τ + for hint in hints do + let some C := db.getClause hint + | return .hintNonexistent hint + match C.reduce τ with + | some #[u] => τ := τ.insert u.var u.polarity + | some #[] => return .contradiction + | _ => return .hintNotUnit hint + return .extended τ + +/-! Theorems about `ClauseDb` -/ + +variable [LawfulBEq α] [HashMap.LawfulHashable α] + +/-! `getClause` -/ + +theorem getClause_eq_some (db : ClauseDb α) (idx : α) (C : IClause) : + db.getClause idx = some C ↔ db.clauses.find? idx = some (C, false) := by + simp [getClause] + +@[simp] +theorem getClause_empty (idx : α) : (empty : ClauseDb α).getClause idx = none := by + simp [getClause, empty] + +theorem getClause_addClause (db : ClauseDb α) (idx : α) (C : IClause) : + (db.addClause idx C).getClause idx = some C := by + dsimp [getClause, addClause] + rw [HashMap.find?_insert _ _ (LawfulBEq.rfl)] + simp + +theorem getClause_addClause_of_ne (db : ClauseDb α) (idx idx' : α) (C : IClause) : + idx ≠ idx' → (db.addClause idx C).getClause idx' = db.getClause idx' := by + intro h + dsimp [addClause, getClause] + rw [HashMap.find?_insert_of_ne _ _ (bne_iff_ne idx idx' |>.mpr h)] + +theorem getClause_delClause (db : ClauseDb α) (idx : α) : + (db.delClause idx).getClause idx = none := by + dsimp [getClause, delClause, HashMap.mapOne] + split + next => + rw [HashMap.find?_insert _ _ (LawfulBEq.rfl)] + simp + next h => + simp [h] + +theorem getClause_delClause_of_ne (db : ClauseDb α) (idx idx' : α) : + idx ≠ idx' → (db.delClause idx).getClause idx' = db.getClause idx' := by + intro h + dsimp [getClause, delClause, HashMap.mapOne] + split + next => + rw [HashMap.find?_insert_of_ne _ _ (bne_iff_ne _ _ |>.mpr h)] + next => rfl + +/-! `contains` -/ + +theorem contains_iff_getClause_eq_some (db : ClauseDb α) (idx : α) : + db.contains idx ↔ ∃ C, db.getClause idx = some C := by + simp [contains, Option.isSome_iff_exists, db.clauses.contains_iff] + +@[simp] +theorem not_contains_empty (idx : α) : (empty : ClauseDb α).contains idx = false := by + have := contains_iff_getClause_eq_some empty idx + simp_all + +theorem contains_addClause (db : ClauseDb α) (idx idx' : α) (C : IClause) : + (db.addClause idx C).contains idx' ↔ (db.contains idx' ∨ idx = idx') := by + simp only [contains_iff_getClause_eq_some] + refine ⟨?mp, fun h => h.elim ?mpr₁ ?mpr₂⟩ + case mp => + intro ⟨C, hGet⟩ + by_cases hEq : idx = idx' <;> + aesop (add norm getClause_addClause_of_ne) + case mpr₁ => + intro ⟨C, hGet⟩ + by_cases hEq : idx = idx' <;> + aesop (add norm getClause_addClause, norm getClause_addClause_of_ne) + case mpr₂ => + aesop (add norm getClause_addClause) + +theorem contains_delClause (db : ClauseDb α) (idx idx' : α) : + (db.delClause idx).contains idx' ↔ (db.contains idx' ∧ idx ≠ idx') := by + simp only [contains_iff_getClause_eq_some] + refine ⟨?mp, ?mpr⟩ + case mp => + intro ⟨C, hGet⟩ + have hEq : idx ≠ idx' := fun h => by + rw [h, getClause_delClause] at hGet + cases hGet + rw [getClause_delClause_of_ne _ _ _ hEq] at hGet + simp [hGet, hEq] + case mpr => + intro ⟨⟨C, hGet⟩, hEq⟩ + exact ⟨C, hGet ▸ getClause_delClause_of_ne _ _ _ hEq⟩ + +/-! `fold` -/ + +theorem fold_of_getClause_eq_some_of_comm (db : ClauseDb α) (idx : α) (C : IClause) + (f : β → α → IClause → β) (init : β) : + db.getClause idx = some C → + (∀ b a₁ C₁ a₂ C₂, f (f b a₁ C₁) a₂ C₂ = f (f b a₂ C₂) a₁ C₁) → + ∃ b, db.fold f init = f b idx C := by + intro h hComm + rw [getClause_eq_some] at h + have ⟨b, hb⟩ := db.clauses.fold_of_mapsTo_of_comm (init := init) + (f := fun acc idx (C, deleted) => if deleted then acc else f acc idx C) + h (by aesop) + use b + simp [fold, hb] + +/-! `all` -/ + +theorem all_true (db : ClauseDb α) (p : α → IClause → Bool) : + db.all p → ∀ idx C, db.getClause idx = some C → p idx C := by + dsimp [all] + intro hAll idx C hGet + have ⟨b, hEq⟩ := + fold_of_getClause_eq_some_of_comm db idx C (fun acc idx C => acc && p idx C) true + hGet ?comm + case comm => + intros + simp only [Bool.and_assoc] + rw [Bool.and_comm (p _ _)] + simp_all + +theorem all_of_all_true (db : ClauseDb α) (p : α → IClause → Bool) : + (∀ idx C, db.getClause idx = some C → p idx C) → db.all p := by + dsimp [all, fold, getClause] + intro + apply db.clauses.foldRecOn (C := fun b => b = true) (hInit := rfl) + simp_all + +/-! `any` -/ + +theorem any_true (db : ClauseDb α) (p : α → IClause → Bool) : + db.any p → ∃ idx C, db.getClause idx = some C ∧ p idx C = true := by + have := db.all_of_all_true (fun idx C => !p idx C) + dsimp [any] + exact not_imp_not.mp fun _ => by simp_all + +/-! `toPropTermSub` -/ + +open Classical PropTerm + +/-- Interpret the conjunction of a subset of the clauses as a Boolean function. -/ +noncomputable def toPropTermSub (db : ClauseDb α) (idxs : Set α) : PropTerm Var := + db.fold (init := ⊤) fun acc idx C => if idx ∈ idxs then acc ⊓ C.toPropTerm else acc + +theorem toPropTermSub_of_getClause_eq_some (db : ClauseDb α) : + idx ∈ idxs → db.getClause idx = some C → db.toPropTermSub idxs ≤ C.toPropTerm := by + intro hMem hGet + have ⟨φ, hφ⟩ := db.fold_of_getClause_eq_some_of_comm idx C + (init := ⊤) (f := fun acc idx C => if idx ∈ idxs then acc ⊓ C.toPropTerm else acc) + hGet ?comm + case comm => + intros + dsimp + split_ifs <;> ac_rfl + apply PropTerm.entails_ext.mpr + rw [toPropTermSub, hφ] + simp [hMem] + +theorem satisfies_toPropTermSub (db : ClauseDb α) (idxs : Set α) (σ : PropAssignment Var) : + σ ⊨ db.toPropTermSub idxs ↔ ∀ idx ∈ idxs, ∀ C, db.getClause idx = some C → σ ⊨ C.toPropTerm := + ⟨mp, mpr⟩ +where + mp := fun h idx hMem C hGet => + entails_ext.mp (toPropTermSub_of_getClause_eq_some db hMem hGet) _ h + + mpr := fun h => by + dsimp [toPropTermSub] + apply HashMap.foldRecOn (hInit := satisfies_tr) + intro φ idx (C, deleted) hφ hFind + dsimp + split_ifs <;> try assumption + next hDel hMem => + rw [satisfies_conj] + refine ⟨by assumption, ?_⟩ + apply h idx hMem + simp [getClause, hFind, hDel] + +@[simp] +theorem toPropTermSub_empty (idxs : Set α) : (empty : ClauseDb α).toPropTermSub idxs = ⊤ := by + ext τ + simp [satisfies_toPropTermSub] + +@[simp] +theorem toPropTermSub_emptySet (db : ClauseDb α) : db.toPropTermSub ∅ = ⊤ := by + ext τ + aesop (add norm satisfies_toPropTermSub) + +theorem toPropTermSub_subset (db : ClauseDb α) : + idxs ⊆ idxs' → db.toPropTermSub idxs' ≤ db.toPropTermSub idxs := by + intro hSub + apply entails_ext.mpr + aesop (add norm satisfies_toPropTermSub) + +theorem toPropTermSub_subset_eq (db : ClauseDb α) : + idxs ⊆ idxs' → (∀ idx ∈ idxs', db.contains idx → idx ∈ idxs) → + db.toPropTermSub idxs' = db.toPropTermSub idxs := by + intro hSub h + apply le_antisymm (toPropTermSub_subset db hSub) + apply entails_ext.mpr + simp only [satisfies_toPropTermSub] + intro τ hτ _ hMem' _ hGet' + exact hτ _ (h _ hMem' (contains_iff_getClause_eq_some _ _ |>.mpr ⟨_, hGet'⟩)) _ hGet' + +theorem toPropTermSub_addClause (db : ClauseDb α) (idxs : Set α) (idx : α) (C : IClause) : + db.toPropTermSub idxs ⊓ C.toPropTerm ≤ (db.addClause idx C).toPropTermSub idxs := by + apply entails_ext.mpr + simp only [satisfies_conj, satisfies_toPropTermSub] + intro τ h idx' C' hMem' hGet' + by_cases hEq : idx = idx' <;> + aesop (add norm getClause_addClause, norm getClause_addClause_of_ne) + +theorem toPropTermSub_addClause_of_not_contains (db : ClauseDb α) (C : IClause) : + ¬db.contains idx → (db.addClause idx C).toPropTermSub idxs ≤ db.toPropTermSub idxs := by + intro hContains + apply entails_ext.mpr + simp only [satisfies_toPropTermSub] + intro _ _ idx' + by_cases hEq : idx = idx' <;> + aesop (add norm contains_iff_getClause_eq_some, norm getClause_addClause_of_ne) + +theorem toPropTermSub_addClause_eq (db : ClauseDb α) (C : IClause) : + idx ∈ idxs → ¬db.contains idx → + (db.addClause idx C).toPropTermSub idxs = db.toPropTermSub idxs ⊓ C.toPropTerm := by + intro hMem hContains + refine le_antisymm ?_ (toPropTermSub_addClause db idxs idx C) + apply le_inf (toPropTermSub_addClause_of_not_contains db C hContains) + apply toPropTermSub_of_getClause_eq_some _ hMem + apply getClause_addClause + +theorem toPropTermSub_addClause_of_not_mem (db : ClauseDb α) (C : IClause) : + idx ∉ idxs → (db.addClause idx C).toPropTermSub idxs = db.toPropTermSub idxs := by + intro hMem + ext τ + simp only [satisfies_toPropTermSub] + constructor <;> { + intro h idx' hMem' + have : idx ≠ idx' := fun h => + hMem <| h ▸ hMem' + aesop (add norm getClause_addClause_of_ne) + } + +theorem toPropTermSub_delClause (db : ClauseDb α) (idxs : Set α) (idx : α) : + db.toPropTermSub idxs ≤ (db.delClause idx).toPropTermSub idxs := by + apply PropTerm.entails_ext.mpr + simp only [satisfies_toPropTermSub] + intro _ _ idx' + by_cases hEq : idx = idx' <;> + aesop (add norm getClause_delClause_of_ne, norm getClause_delClause) + +theorem toPropTermSub_delClause_of_getClause_eq_some (db : ClauseDb α) : + db.getClause idx = some C → + (db.delClause idx).toPropTermSub idxs ⊓ C.toPropTerm ≤ db.toPropTermSub idxs := by + intro hGet + apply entails_ext.mpr + simp only [satisfies_conj, satisfies_toPropTermSub] + intro _ _ idx' + by_cases hEq : idx = idx' <;> + aesop (add norm getClause_delClause_of_ne) + +theorem toPropTermSub_delClause_eq (db : ClauseDb α) : + idx ∈ idxs → db.getClause idx = some C → + (db.delClause idx).toPropTermSub idxs ⊓ C.toPropTerm = db.toPropTermSub idxs := by + intro hMem hGet + apply le_antisymm (toPropTermSub_delClause_of_getClause_eq_some db hGet) + apply le_inf (toPropTermSub_delClause db idxs idx) + apply toPropTermSub_of_getClause_eq_some _ hMem hGet + +theorem toPropTermSub_delClause_of_not_mem (db : ClauseDb α) : + idx ∉ idxs → (db.delClause idx).toPropTermSub idxs = db.toPropTermSub idxs := by + intro hMem + ext τ + simp only [satisfies_toPropTermSub] + constructor <;> { + intro h idx' hMem' + have : idx ≠ idx' := fun h => + hMem <| h ▸ hMem' + aesop (add norm getClause_delClause_of_ne) + } + +/-! `toPropTerm` -/ + +/-- Interpret the conjuction of all the clauses as a Boolean function. -/ +noncomputable def toPropTerm (db : ClauseDb α) : PropTerm Var := + db.toPropTermSub Set.univ + +theorem toPropTerm_of_getClause_eq_some (db : ClauseDb α) : + db.getClause idx = some C → db.toPropTerm ≤ C.toPropTerm := + toPropTermSub_of_getClause_eq_some db (Set.mem_univ idx) + +open PropTerm in +theorem satisfies_toPropTerm (db : ClauseDb α) (σ : PropAssignment Var) : + σ ⊨ db.toPropTerm ↔ ∀ idx C, db.getClause idx = some C → σ ⊨ C.toPropTerm := + have ⟨mp, mpr⟩ := satisfies_toPropTermSub db Set.univ σ + ⟨fun h idx C hGet => mp h idx (Set.mem_univ idx) C hGet, + fun h => mpr (fun idx _ C hGet => h idx C hGet)⟩ + +theorem toPropTerm_subset (db : ClauseDb α) (idxs : Set α) : + db.toPropTerm ≤ db.toPropTermSub idxs := + toPropTermSub_subset db (Set.subset_univ idxs) + +@[simp] +theorem toPropTerm_empty : (empty : ClauseDb α).toPropTerm = ⊤ := + toPropTermSub_empty Set.univ + +theorem toPropTerm_addClause (db : ClauseDb α) (idx : α) (C : IClause) : + db.toPropTerm ⊓ C.toPropTerm ≤ (db.addClause idx C).toPropTerm := + toPropTermSub_addClause db Set.univ idx C + +theorem toPropTerm_addClause_eq (db : ClauseDb α) (idx : α) (C : IClause) : + ¬db.contains idx → + (db.addClause idx C).toPropTerm = db.toPropTerm ⊓ C.toPropTerm := + toPropTermSub_addClause_eq db C (Set.mem_univ idx) + +theorem toPropTerm_delClause (db : ClauseDb α) (idx : α) : + db.toPropTerm ≤ (db.delClause idx).toPropTerm := + toPropTermSub_delClause db Set.univ idx + +theorem toPropTerm_delClause_eq (db : ClauseDb α) (idx : α) (C : IClause) : + db.getClause idx = some C → + (db.delClause idx).toPropTerm ⊓ C.toPropTerm = db.toPropTerm := + toPropTermSub_delClause_eq db (Set.mem_univ idx) + +/-! `ofICnf` -/ + +theorem ofICnf_characterization (cnf : ICnf) : + ¬(ofICnf cnf).contains 0 ∧ + (∀ i : Fin cnf.size, (ofICnf cnf).getClause (i + 1) = some cnf[i]) ∧ + (∀ i > cnf.size, ¬(ofICnf cnf).contains i) := by + have ⟨h₁, h₂, h₃, _⟩ := cnf.foldl_induction + (motive := fun (sz : Nat) (p : ClauseDb Nat × Nat) => + ¬p.1.contains 0 ∧ + (∀ i : Fin cnf.size, i < sz → p.1.getClause (i + 1) = some cnf[i]) ∧ + (∀ i > sz, ¬p.1.contains i) ∧ + p.2 = sz + 1) + (init := (empty, 1)) + (f := fun (db, idx) C => (db.addClause idx C, idx + 1)) + (h0 := by simp [not_contains_empty]) + (hf := by + intro sz (db, idx) ⟨ih₁, ih₂, ih₃, ih₄⟩ + dsimp at ih₄ ⊢ + simp only [ih₄, contains_iff_getClause_eq_some, and_true] at * + refine ⟨?step₁, ?step₂, ?step₃⟩ + case step₁ => + have : sz.val + 1 ≠ 0 := Nat.succ_ne_zero _ + simp [getClause_addClause_of_ne _ _ _ _ this, ih₁] + case step₂ => + intro i hLt + by_cases hEq : sz.val = i.val + . simp [hEq, getClause_addClause] + . have : sz.val + 1 ≠ i.val + 1 := by simp [hEq] + rw [getClause_addClause_of_ne _ _ _ _ this] + apply ih₂ + exact Nat.lt_of_le_of_ne (Nat.le_of_lt_succ hLt) (Ne.symm hEq) + case step₃ => + intro i hGe + have : sz.val + 1 ≠ i := Nat.ne_of_lt hGe + rw [getClause_addClause_of_ne _ _ _ _ this] + apply ih₃ + linarith) + dsimp [ofICnf] + exact ⟨h₁, fun i => h₂ i i.isLt, h₃⟩ + +theorem ofICnf_ext (cnf : ICnf) (C : IClause) : + C ∈ cnf.data ↔ ∃ idx, (ofICnf cnf).getClause idx = some C := by + have ⟨h₁, h₂, h₃⟩ := ofICnf_characterization cnf + apply Iff.intro + case mp => + intro h + have ⟨i, h⟩ := Array.get_of_mem_data h + use (i + 1) + rw [← h] + apply h₂ + case mpr => + intro ⟨idx, h⟩ + have hContains := contains_iff_getClause_eq_some _ _ |>.mpr ⟨C, h⟩ + have hPos : 0 < idx := by + apply Nat.pos_of_ne_zero + intro + simp_all + have hLt : idx - 1 < cnf.size := by + suffices idx ≤ cnf.size by + apply Nat.sub_lt_left_of_lt_add + . apply Nat.succ_le_of_lt hPos + . rw [add_comm] + apply Nat.lt_succ_of_le this + by_contra + simp_all + have hPred : idx - 1 + 1 = idx := Nat.succ_pred_eq_of_pos hPos + have := h₂ ⟨idx - 1, hLt⟩ + simp only [hPred, h] at this + cases this + apply Array.get_mem_data + +@[simp] +theorem toPropTerm_ofICnf (cnf : ICnf) : (ofICnf cnf).toPropTerm = cnf.toPropTerm := by + ext τ + simp only [ICnf.satisfies_iff, satisfies_toPropTerm, ofICnf_ext] + aesop + +/-! `unitPropWithHints` -/ + +inductive UnitPropResultDep {α : Type} [BEq α] [Hashable α] + (db : ClauseDb α) (σ : PartPropAssignment) (hints : Array α) where + /-- A contradiction was derived. The contradiction is implied by the subset of the database + used in hints as well as the initial assignment. -/ + | contradiction (h : db.toPropTermSub (· ∈ hints.data) ⊓ σ.toPropTerm ≤ ⊥) + /-- The partial assignment was extended. The final assignment `σ'` is implied by the subset of + the database used in hints as well as the initial assignment. -/ + | extended (σ' : PartPropAssignment) + (h : db.toPropTermSub (· ∈ hints.data) ⊓ σ.toPropTerm ≤ σ'.toPropTerm) + /-- The hint `C` at index `idx` did not become unit under `σ`. -/ + | hintNotUnit (idx : α) (C : IClause) (σ : PartPropAssignment) + /-- The hint index `idx` points at a nonexistent clause. -/ + | hintNonexistent (idx : α) + +/-- Check whether the given clause is a unit and return the unit literal if so. Otherwise fail. +Note that repeating a literal as in (l ∨ l ∨ l) is allowed and counts as a unit. -/ +def checkIsUnit (C₀ : IClause) : Option { l : ILit // l.toPropTerm = C₀.toPropTerm } := do + let ⟨l?, _, hL?⟩ ← loopM_with_invariant (n := C₀.size) + (invariant := fun i (acc : Option ILit) => + (acc = none → i = 0) ∧ + ∀ l, acc = some l → + l ∈ C₀.data ∧ + ∀ j : Fin C₀.size, j < i → C₀[j] = l) + (start_state := ⟨none, by simp⟩) + (step := fun i ⟨acc, ih₁, _⟩ => do + let lᵢ := C₀[i] + have hL : lᵢ ∈ C₀.data := C₀.get_mem_data i + if hI : i.val = 0 then + return ⟨some lᵢ, by simp, by simp_all⟩ + else + match acc with + | some l => + if h : lᵢ = l then + return ⟨some lᵢ, by simp, by + intro _ h + injection h with h; cases h + refine ⟨hL, fun j hJ => ?_⟩ + cases Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hJ) <;> + simp_all⟩ + else + none + | none => False.elim <| hI <| ih₁ rfl) + match l?, hL? with + | some l, hL => + return ⟨l, by + ext + have ⟨_, h₂⟩ := hL _ rfl + have : ∀ l' ∈ C₀.data, l' = l := fun _ hL' => + have ⟨i, hI⟩ := Array.get_of_mem_data hL' + hI ▸ h₂ i i.isLt + aesop (add norm IClause.satisfies_iff)⟩ + | none, _ => none + +/-- Propagate units starting from the given assignment. The clauses in `hints` are expected +to become unit in the order provided. Return the extended assignment, or `none` if a contradiction +was found. See `unitPropWithHintsDep` for a certified version. -/ +def unitPropWithHintsDep (db : ClauseDb α) (σ₀ : PartPropAssignment) (hints : Array α) + : UnitPropResultDep db σ₀ hints := Id.run do + let mut σ : {σ : PartPropAssignment // + db.toPropTermSub (· ∈ hints.data) ⊓ σ₀.toPropTerm ≤ σ.toPropTerm } := + ⟨σ₀, inf_le_right⟩ + for h : i in [0:hints.size] do + let hint := hints[i]'(Membership.mem.upper h) + have hMem : hint ∈ hints.data := Array.getElem_mem_data hints _ + + match hGet : db.getClause hint with + | none => return .hintNonexistent hint + | some C => + have hDbσ₀ : + db.toPropTermSub (· ∈ hints.data) ⊓ σ₀.toPropTerm ≤ C.toPropTerm ⊓ σ.val.toPropTerm := + le_inf (inf_le_of_left_le (toPropTermSub_of_getClause_eq_some db hMem hGet)) σ.property + match hRed : C.reduce σ.val with + | some #[] => + have : db.toPropTermSub (· ∈ hints.data) ⊓ σ₀.toPropTerm ≤ ⊥ := by + have : C.toPropTerm ⊓ σ.val.toPropTerm ≤ ⊥ := + IClause.reduce_eq_some _ _ _ hRed + exact le_trans hDbσ₀ this + return .contradiction this + | some C' => + let some ⟨u, hU⟩ := checkIsUnit C' + | return .hintNotUnit hint C σ.val + have : db.toPropTermSub (· ∈ hints.data) ⊓ σ₀.toPropTerm ≤ + PartPropAssignment.toPropTerm (σ.val.insert u.var u.polarity) := by + have hU : db.toPropTermSub (· ∈ hints.data) ⊓ σ₀.toPropTerm ≤ u.toPropTerm := by + have h := IClause.reduce_eq_some _ _ _ hRed + conv at h => rhs; rw [← hU]; simp [IClause.toPropTerm] + exact le_trans hDbσ₀ h + refine PropTerm.entails_ext.mpr fun τ hτ => ?_ + have hU : τ ⊨ u.toPropTerm := + PropTerm.entails_ext.mp hU τ hτ + have hσ : τ ⊨ σ.val.toPropTerm := + PropTerm.entails_ext.mp σ.property τ hτ + rw [PartPropAssignment.satisfies_iff] at hσ ⊢ + intro x p hFind + by_cases hEq : x = u.var + next => + rw [hEq, HashMap.find?_insert _ _ LawfulBEq.rfl] at hFind + rw [ILit.satisfies_iff] at hU + simp_all + next => + rw [HashMap.find?_insert_of_ne _ _ (bne_iff_ne _ _ |>.mpr (Ne.symm hEq))] at hFind + exact hσ _ _ hFind + σ := ⟨σ.val.insert u.var u.polarity, this⟩ + | _ => return .hintNotUnit hint C σ.val + return .extended σ.val σ.property + +end ClauseDb diff --git a/Experiments/CPOG/Data/HashMap/Basic.lean b/Experiments/CPOG/Data/HashMap/Basic.lean new file mode 100644 index 0000000..ec69af1 --- /dev/null +++ b/Experiments/CPOG/Data/HashMap/Basic.lean @@ -0,0 +1,352 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Mario Carneiro +-/ +import Std.Data.AssocList +import Std.Data.Nat.Basic +import Std.Classes.BEq + +namespace HashMap +open Std + +/-- A hash is lawful if elements which compare equal under `==` have equal hash. -/ +class LawfulHashable (α : Type _) [BEq α] [Hashable α] : Prop where + /-- Two elements which compare equal under the `BEq` instance have equal hash. -/ + hash_eq {a b : α} : a == b → hash a = hash b + +instance [BEq α] [LawfulBEq α] [Hashable α] : LawfulHashable α where + hash_eq h := by rw [LawfulBEq.eq_of_beq h] + +namespace Imp + +/-- +The bucket array of a `HashMap` is a nonempty array of `AssocList`s. +(This type is an internal implementation detail of `HashMap`.) +-/ +def Buckets (α : Type u) (β : Type v) := {b : Array (AssocList α β) // b.size.isPowerOfTwo} + +namespace Buckets + +/-- Construct a new empty bucket array with the specified number of buckets. -/ +def mk (nBuckets : Nat) (h : nBuckets.isPowerOfTwo) : Buckets α β := + ⟨mkArray nBuckets .nil, by simp [h]⟩ + +/-- Update one bucket in the bucket array with a new value. -/ +def update (data : Buckets α β) (i : USize) + (d : AssocList α β) (h : i.toNat < data.1.size) : Buckets α β := + ⟨data.1.uset i d h, (Array.size_uset ..).symm ▸ data.2⟩ + +/-- +The number of elements in the bucket array. +Note: this is marked `noncomputable` because it is only intended for specification. +-/ +noncomputable def size (data : Buckets α β) : Nat := .sum (data.1.data.map (·.toList.length)) + +/-- Map a function over the values in the map. -/ +@[specialize] def mapVal (f : α → β → γ) (self : Buckets α β) : Buckets α γ := + ⟨self.1.map (.mapVal f), by simp [self.2]⟩ + +/-- +The well-formedness invariant for the bucket array says that every element hashes to its index +(assuming the hash is lawful - otherwise there are no promises about where elements are located). +-/ +structure WF [BEq α] [Hashable α] (buckets : Buckets α β) : Prop where + /-- The elements of a bucket are all distinct according to the `BEq` relation. -/ + distinct [LawfulHashable α] [PartialEquivBEq α] : ∀ bucket ∈ buckets.1.data, + bucket.toList.Pairwise fun a b => ¬(a.1 == b.1) + /-- Every element in a bucket should hash to its location. -/ + hash_self (i : Nat) (h : i < buckets.1.size) : + buckets.1[i].All fun k _ => ((hash k).toUSize % buckets.1.size).toNat = i + +end Buckets +end Imp + +/-- `HashMap.Imp α β` is the internal implementation type of `HashMap α β`. -/ +structure Imp (α : Type u) (β : Type v) where + /-- The number of elements stored in the `HashMap`. + We cache this both so that we can implement `.size` in `O(1)`, and also because we + use the size to determine when to resize the map. -/ + size : Nat + /-- The bucket array of the `HashMap`. -/ + buckets : Imp.Buckets α β + +namespace Imp + +/-- +Given a desired capacity, this returns the number of buckets we should reserve. +A "load factor" of 0.75 is the usual standard for hash maps, so we return `capacity * 4 / 3`. +-/ +@[inline] def numBucketsForCapacity (capacity : Nat) : Nat := + capacity * 4 / 3 + +/-- Constructs an empty hash map with the specified nonzero number of buckets. -/ +@[inline] def empty' (nBuckets : Nat) (h : nBuckets.isPowerOfTwo) : Imp α β := + ⟨0, .mk nBuckets h⟩ + +/-- Constructs an empty hash map with the specified target capacity. -/ +def empty (capacity := 8) : Imp α β := + let nBuckets := numBucketsForCapacity capacity |>.nextPowerOfTwo + empty' nBuckets (Nat.isPowerOfTwo_nextPowerOfTwo _) + +/-- Calculates the bucket index from a `hash` value. -/ +def mkIdx {sz : Nat} (hash : UInt64) (h : sz.isPowerOfTwo) : {u : USize // u.toNat < sz} := + ⟨hash.toUSize % sz, USize.modn_lt _ (Nat.pos_of_isPowerOfTwo h)⟩ + +/-- +Inserts a key-value pair into the bucket array. This function assumes that the data is not +already in the array, which is appropriate when reinserting elements into the array after a resize. +-/ +@[inline] def reinsertAux [Hashable α] (data : Buckets α β) (a : α) (b : β) : Buckets α β := + let ⟨i, h⟩ := mkIdx (hash a) data.property + data.update i (.cons a b data.1[i]) h + +/-- Folds a monadic function over the elements in the map (in arbitrary order). -/ +@[inline] def foldM [Monad m] (f : δ → α → β → m δ) (d : δ) (map : Imp α β) : m δ := + map.buckets.1.foldlM (init := d) fun d b => b.foldlM f d + +/-- Folds a function over the elements in the map (in arbitrary order). -/ +@[inline] def fold (f : δ → α → β → δ) (d : δ) (map : Imp α β) : δ := + map.buckets.1.foldl (init := d) fun d b => b.foldl f d + +/-- Runs a monadic function over the elements in the map (in arbitrary order). -/ +@[inline] def forM [Monad m] (f : α → β → m PUnit) (h : Imp α β) : m PUnit := + h.buckets.1.forM fun b => b.forM f + +/-- Given a key `a`, returns a key-value pair in the map whose key compares equal to `a`. -/ +def findEntry? [BEq α] [Hashable α] (m : Imp α β) (a : α) : Option (α × β) := + let ⟨_, buckets⟩ := m + let ⟨i, h⟩ := mkIdx (hash a) buckets.property + buckets.1[i].findEntry? a + +/-- Looks up an element in the map with key `a`. -/ +def find? [BEq α] [Hashable α] (m : Imp α β) (a : α) : Option β := + let ⟨_, buckets⟩ := m + let ⟨i, h⟩ := mkIdx (hash a) buckets.property + buckets.1[i].find? a + +/-- Returns true if the element `a` is in the map. -/ +def contains [BEq α] [Hashable α] (m : Imp α β) (a : α) : Bool := + let ⟨_, buckets⟩ := m + let ⟨i, h⟩ := mkIdx (hash a) buckets.property + buckets.1[i].contains a + +/-- Copies all the entries from `buckets` into a new hash map with a larger capacity. -/ +def expand [Hashable α] (size : Nat) (buckets : Buckets α β) : Imp α β := + let nbuckets := buckets.1.size * 2 + have h : nbuckets.isPowerOfTwo := Nat.mul2_isPowerOfTwo_of_isPowerOfTwo buckets.property + { size, buckets := go 0 buckets.1 (.mk nbuckets h) } +where + /-- Inner loop of `expand`. Copies elements `source[i:]` into `target`, + destroying `source` in the process. -/ + go (i : Nat) (source : Array (AssocList α β)) (target : Buckets α β) : Buckets α β := + if h : i < source.size then + let idx : Fin source.size := ⟨i, h⟩ + let es := source.get idx + -- We remove `es` from `source` to make sure we can reuse its memory cells + -- when performing es.foldl + let source := source.set idx .nil + let target := es.foldl reinsertAux target + go (i+1) source target + else target +termination_by go i source _ => source.size - i + +/-- +Inserts key-value pair `a, b` into the map. +If an element equal to `a` is already in the map, it is replaced by `b`. +-/ +@[inline] def insert [BEq α] [Hashable α] (m : Imp α β) (a : α) (b : β) : Imp α β := + let ⟨size, buckets⟩ := m + let ⟨i, h⟩ := mkIdx (hash a) buckets.property + let bkt := buckets.1[i] + bif bkt.contains a then + ⟨size, buckets.update i (bkt.replace a b) h⟩ + else + let size' := size + 1 + let buckets' := buckets.update i (.cons a b bkt) h + if numBucketsForCapacity size' ≤ buckets.1.size then + { size := size', buckets := buckets' } + else + expand size' buckets' + +/-- +Removes key `a` from the map. If it does not exist in the map, the map is returned unchanged. +-/ +def erase [BEq α] [Hashable α] (m : Imp α β) (a : α) : Imp α β := + let ⟨size, buckets⟩ := m + let ⟨i, h⟩ := mkIdx (hash a) buckets.property + let bkt := buckets.1[i] + bif bkt.contains a then ⟨size - 1, buckets.update i (bkt.erase a) h⟩ else m + +/-- Map a function over the values in the map. -/ +@[inline] def mapVal (f : α → β → γ) (self : Imp α β) : Imp α γ := + { size := self.size, buckets := self.buckets.mapVal f } + +/-- +Applies `f` to each key-value pair `a, b` in the map. If it returns `some c` then +`a, c` is pushed into the new map; else the key is removed from the map. +-/ +@[specialize] def filterMap {α : Type u} {β : Type v} {γ : Type w} + (f : α → β → Option γ) (m : Imp α β) : Imp α γ := + let m' := m.buckets.1.mapM (m := StateT (ULift Nat) Id) (go .nil) |>.run ⟨0⟩ |>.run + have : m'.1.size.isPowerOfTwo := by + have := Array.size_mapM (m := StateT (ULift Nat) Id) (go .nil) m.buckets.1 + simp [SatisfiesM_StateT_eq, SatisfiesM_Id_eq] at this + simp [this, Id.run, StateT.run, m.2.2] + ⟨m'.2.1, m'.1, this⟩ +where + /-- Inner loop of `filterMap`. Note that this reverses the bucket lists, + but this is fine since bucket lists are unordered. -/ + @[specialize] go (acc : AssocList α γ) : AssocList α β → ULift Nat → AssocList α γ × ULift Nat + | .nil, n => (acc, n) + | .cons a b l, n => match f a b with + | none => go acc l n + | some c => go (.cons a c acc) l ⟨n.1 + 1⟩ + +/-- Constructs a map with the set of all pairs `a, b` such that `f` returns true. -/ +@[inline] def filter (f : α → β → Bool) (m : Imp α β) : Imp α β := + m.filterMap fun a b => bif f a b then some b else none + +/-- +The well-formedness invariant for a hash map. The first constructor is the real invariant, +and the others allow us to "cheat" in this file and define `insert` and `erase`, +which have more complex proofs that are delayed to `Std.Data.HashMap.Lemmas`. +-/ +inductive WF [BEq α] [Hashable α] : Imp α β → Prop where + /-- The real well-formedness invariant: + * The `size` field should match the actual number of elements in the map + * The bucket array should be well-formed, meaning that if the hashable instance + is lawful then every element hashes to its index. -/ + | mk : m.size = m.buckets.size → m.buckets.WF → WF m + /-- The empty hash map is well formed. -/ + | empty' : WF (empty' n h) + /-- Inserting into a well formed hash map yields a well formed hash map. -/ + | insert : WF m → WF (insert m a b) + /-- Removing an element from a well formed hash map yields a well formed hash map. -/ + | erase : WF m → WF (erase m a) + +theorem WF.empty [BEq α] [Hashable α] : WF (empty n : Imp α β) := by unfold empty; apply empty' + +end Imp + +/-- +`HashMap α β` is a key-value map which stores elements in an array using a hash function +to find the values. This allows it to have very good performance for lookups +(average `O(1)` for a perfectly random hash function), but it is not a persistent data structure, +meaning that one should take care to use the map linearly when performing updates. +Copies are `O(n)`. +-/ +def _root_.HashMap (α : Type u) (β : Type v) [BEq α] [Hashable α] := {m : Imp α β // m.WF} + +open HashMap.Imp + +/-- Make a new hash map with the specified capacity. -/ +@[inline] def _root_.mkHashMap [BEq α] [Hashable α] (capacity := 8) : HashMap α β := + ⟨.empty capacity, .empty⟩ + +instance [BEq α] [Hashable α] : Inhabited (HashMap α β) where + default := mkHashMap + +instance [BEq α] [Hashable α] : EmptyCollection (HashMap α β) := ⟨mkHashMap⟩ + +/-- Make a new empty hash map. -/ +@[inline] def empty [BEq α] [Hashable α] : HashMap α β := mkHashMap + +variable {_ : BEq α} {_ : Hashable α} + +/-- The number of elements in the hash map. -/ +@[inline] def size (self : HashMap α β) : Nat := self.1.size + +/-- Is the map empty? -/ +@[inline] def isEmpty (self : HashMap α β) : Bool := self.size = 0 + +/-- +Inserts key-value pair `a, b` into the map. +If an element equal to `a` is already in the map, it is replaced by `b`. +-/ +def insert (self : HashMap α β) (a : α) (b : β) : HashMap α β := ⟨self.1.insert a b, self.2.insert⟩ + +/-- +Similar to `insert`, but also returns a boolean flag indicating whether an existing entry has been +replaced with `a ↦ b`. +-/ +@[inline] def insert' (m : HashMap α β) (a : α) (b : β) : HashMap α β × Bool := + let old := m.size + let m' := m.insert a b + let replaced := old == m'.size + (m', replaced) + +/-- +Removes key `a` from the map. If it does not exist in the map, the map is returned unchanged. +-/ +@[inline] def erase (self : HashMap α β) (a : α) : HashMap α β := ⟨self.1.erase a, self.2.erase⟩ + +/-- Given a key `a`, returns a key-value pair in the map whose key compares equal to `a`. -/ +@[inline] def findEntry? (self : HashMap α β) (a : α) : Option (α × β) := self.1.findEntry? a + +/-- Looks up an element in the map with key `a`. -/ +@[inline] def find? (self : HashMap α β) (a : α) : Option β := self.1.find? a + +/-- Looks up an element in the map with key `a`. Returns `b₀` if the element is not found. -/ +@[inline] def findD (self : HashMap α β) (a : α) (b₀ : β) : β := (self.find? a).getD b₀ + +/-- Looks up an element in the map with key `a`. Panics if the element is not found. -/ +@[inline] def find! [Inhabited β] (self : HashMap α β) (a : α) : β := + (self.find? a).getD (panic! "key is not in the map") + +instance : GetElem (HashMap α β) α (Option β) fun _ _ => True where + getElem m k _ := m.find? k + +/-- Returns true if the element `a` is in the map. -/ +@[inline] def contains (self : HashMap α β) (a : α) : Bool := self.1.contains a + +/-- Folds a monadic function over the elements in the map (in arbitrary order). -/ +@[inline] def foldM [Monad m] (f : δ → α → β → m δ) (init : δ) (self : HashMap α β) : m δ := + self.1.foldM f init + +/-- Folds a function over the elements in the map (in arbitrary order). -/ +@[inline] def fold (f : δ → α → β → δ) (init : δ) (self : HashMap α β) : δ := self.1.fold f init + +/-- Combines two hashmaps using a monadic function `f` to combine two values at a key. -/ +@[specialize] def mergeWithM [Monad m] (f : α → β → β → m β) + (self other : HashMap α β) : m (HashMap α β) := + other.foldM (init := self) fun m k v₂ => + match m.find? k with + | none => return m.insert k v₂ + | some v₁ => return m.insert k (← f k v₁ v₂) + +/-- Combines two hashmaps using function `f` to combine two values at a key. -/ +@[inline] def mergeWith (f : α → β → β → β) (self other : HashMap α β) : HashMap α β := + -- Implementing this function directly, rather than via `mergeWithM`, gives + -- us less constrained universes. + other.fold (init := self) λ map k v₂ => + match map.find? k with + | none => map.insert k v₂ + | some v₁ => map.insert k $ f k v₁ v₂ + +/-- Runs a monadic function over the elements in the map (in arbitrary order). -/ +@[inline] def forM [Monad m] (f : α → β → m PUnit) (self : HashMap α β) : m PUnit := self.1.forM f + +/-- Converts the map into a list of key-value pairs. -/ +def toList (self : HashMap α β) : List (α × β) := self.fold (init := []) fun r k v => (k, v)::r + +/-- Converts the map into an array of key-value pairs. -/ +def toArray (self : HashMap α β) : Array (α × β) := + self.fold (init := #[]) fun r k v => r.push (k, v) + +/-- The number of buckets in the hash map. -/ +def numBuckets (self : HashMap α β) : Nat := self.1.buckets.1.size + +/-- +Builds a `HashMap` from a list of key-value pairs. +Values of duplicated keys are replaced by their respective last occurrences. +-/ +def ofList (l : List (α × β)) : HashMap α β := + l.foldl (init := HashMap.empty) fun m (k, v) => m.insert k v + +/-- Variant of `ofList` which accepts a function that combines values of duplicated keys. -/ +def ofListWith (l : List (α × β)) (f : β → β → β) : HashMap α β := + l.foldl (init := HashMap.empty) fun m p => + match m.find? p.1 with + | none => m.insert p.1 p.2 + | some v => m.insert p.1 <| f v p.2 diff --git a/Experiments/CPOG/Data/HashMap/Lemmas.lean b/Experiments/CPOG/Data/HashMap/Lemmas.lean new file mode 100644 index 0000000..ec43551 --- /dev/null +++ b/Experiments/CPOG/Data/HashMap/Lemmas.lean @@ -0,0 +1,524 @@ +/- +Copyright (c) 2022 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ +import Std.Data.List.Lemmas +import Std.Data.Array.Lemmas +import Std.Tactic.ShowTerm + +import Mathlib.Data.List.Perm + +import ProofChecker.Model.ToMathlib +import ProofChecker.Data.HashMap.Basic +import ProofChecker.Data.HashMap.WF + +namespace HashMap +open Std (AssocList) +variable [BEq α] [Hashable α] [LawfulHashable α] [PartialEquivBEq α] + +namespace Imp +open List + +-- NOTE(WN): These would ideally be solved by a congruence-closure-for-PERs tactic +-- See https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Rewriting.20congruent.20relations +-- Same for proofs about List.Perm +private theorem beq_nonsense_1 {a b c : α} : a != b → a == c → b != c := + fun h₁ h₂ => Bool.bne_iff_not_beq.mpr fun h₃ => + Bool.bne_iff_not_beq.mp h₁ (PartialEquivBEq.trans h₂ (PartialEquivBEq.symm h₃)) + +private theorem beq_nonsense_2 {a b c : α} : a == b → b == c → ¬(c != a) := + fun h₁ h₂ h₃ => Bool.bne_iff_not_beq.mp (bne_symm h₃) (PartialEquivBEq.trans h₁ h₂) + +private theorem beq_nonsense_3 {a b c : α} : a != b → c == b → c != a := + fun h₁ h₂ => bne_symm (beq_nonsense_1 (bne_symm h₁) (PartialEquivBEq.symm h₂)) + +namespace Buckets + +/-- The contents of any given bucket are pairwise `bne`. -/ +theorem Pairwise_bne_bucket (bkts : Buckets α β) (H : bkts.WF) (h : i < bkts.val.size) : + Pairwise (·.1 != ·.1) bkts.val[i].toList := by + have := H.distinct bkts.val[i] (Array.getElem_mem_data _ _) + exact Pairwise.imp Bool.bne_iff_not_beq.mpr this + +/-- Reformulation of `Pairwise_bne_bucket` for use with `List.foo_of_unique`. -/ +theorem Pairwise_bne_bucket' (bkts : Buckets α β) (H : bkts.WF) (h : i < bkts.val.size) (a : α) : + Pairwise (fun p q => p.1 == a → q.1 != a) bkts.val[i].toList := + Pairwise.imp beq_nonsense_1 (Pairwise_bne_bucket bkts H h) + +/-! ## Main abstraction using `toListModel` -/ + +/-- It is a bit easier to reason about `foldl (append)` than `foldl (foldl)`, so we use this +(less efficient) variant of `toList` as the mathematical model. -/ +def toListModel (bkts : Buckets α β) : List (α × β) := + -- Note(WN): the implementation is `bkts.foldl` rather than `bkts.data.foldl` because we need + -- to reason about array indices in some of the theorems. + bkts.val.foldl (init := []) (fun acc bkt => acc ++ bkt.toList) + +attribute [local simp] foldl_cons_fn foldl_append_fn + +theorem toListModel_eq (bkts : Buckets α β) : bkts.toListModel = bkts.val.data.bind (·.toList) := by + simp [toListModel, Array.foldl_eq_foldl_data] + +theorem mem_toListModel_iff_mem_bucket (bkts : Buckets α β) (H : bkts.WF) (ab : α × β) : + haveI := mkIdx (hash ab.fst) bkts.property + ab ∈ bkts.toListModel ↔ ab ∈ (bkts.val[this.1.toNat]'this.2).toList := by + have : ab ∈ bkts.toListModel ↔ ∃ bkt ∈ bkts.val.data, ab ∈ bkt.toList := by + simp [toListModel_eq, mem_bind] + rw [this] + clear this + apply Iff.intro + . intro ⟨bkt, hBkt, hMem⟩ + have ⟨i, hGetI⟩ := Array.get_of_mem_data hBkt + simp only [getElem_fin] at hGetI + suffices (mkIdx (hash ab.fst) bkts.property).val.toNat = i by + simp [Array.ugetElem_eq_getElem, this, hGetI, hMem] + unfold Imp.mkIdx + dsimp + exact H.hash_self i.val i.isLt ab (hGetI ▸ hMem) + . intro h + refine ⟨_, Array.getElem_mem_data _ _, h⟩ + +/-- The map does not store duplicate (by `beq`) keys. -/ +theorem Pairwise_bne_toListModel (bkts : Buckets α β) (H : bkts.WF) : + bkts.toListModel.Pairwise (·.1 != ·.1) := by + unfold toListModel + refine Array.foldl_induction + (motive := fun i (acc : List (α × β)) => + -- The acc has the desired property + acc.Pairwise (·.1 != ·.1) + -- All not-yet-accumulated buckets are pairwise disjoint with the acc + ∧ ∀ j, i ≤ j → (_ : j < bkts.val.size) → + ∀ p ∈ acc, ∀ r ∈ bkts.val[j].toList, p.1 != r.1) + ?h0 ?hf |>.left + case h0 => exact ⟨Pairwise.nil, fun.⟩ + case hf => + intro i acc h + refine ⟨pairwise_append.mpr ⟨h.left, ?bkt, ?accbkt⟩, ?accbkts⟩ + case bkt => apply Pairwise_bne_bucket bkts H + case accbkt => + intro a hA b hB + exact h.right i.val (Nat.le_refl _) i.isLt a hA b hB + case accbkts => + intro j hGe hLt p hP r hR + cases mem_append.mp hP + case inl hP => exact h.right j (Nat.le_of_succ_le hGe) hLt p hP r hR + case inr hP => + -- Main proof 2: distinct buckets store bne keys + refine Bool.bne_iff_not_beq.mpr fun h => ?_ + have hHashEq := LawfulHashable.hash_eq h + have hGt := Nat.lt_of_succ_le hGe + have hHashP := H.hash_self i (Nat.lt_trans hGt hLt) _ hP + have hHashR := H.hash_self j hLt _ hR + dsimp at hHashP hHashR + have : i.val = j := by + rw [hHashEq] at hHashP + exact .trans hHashP.symm hHashR + exact Nat.ne_of_lt hGt this + +/-- Reformulation of `Pairwise_bne_toListModel` for use with `List.foo_of_unique`. -/ +-- TODO: rm in favor of below +theorem Pairwise_bne_toListModel' (bkts : Buckets α β) (H : bkts.WF) (a : α) : + bkts.toListModel.Pairwise (fun p q => p.1 == a → q.1 != a) := + Pairwise.imp beq_nonsense_1 (Pairwise_bne_toListModel bkts H) + +theorem unique_toListModel (bkts : Buckets α β) (H : bkts.WF) (a : α) : + bkts.toListModel.unique (·.1 == a) := + Pairwise.imp + (fun h h₁ h₂ => Bool.bne_iff_not_beq.mp (h h₁) h₂) + (Pairwise_bne_toListModel' bkts H a) + +@[simp] +theorem toListModel_mk (size : Nat) (h : size.isPowerOfTwo) : + (Buckets.mk (α := α) (β := β) size h).toListModel = [] := by + simp only [Buckets.mk, toListModel_eq, mkArray_data] + clear h + induction size <;> simp [*] + +theorem exists_of_toListModel_update (bkts : Buckets α β) (i d h) : + ∃ l₁ l₂, bkts.toListModel = l₁ ++ bkts.1[i.toNat].toList ++ l₂ + ∧ (bkts.update i d h).toListModel = l₁ ++ d.toList ++ l₂ := by + have ⟨bs₁, bs₂, hTgt, _, hUpd⟩ := bkts.exists_of_update i d h + refine ⟨bs₁.bind (·.toList), bs₂.bind (·.toList), ?_, ?_⟩ + . simp [toListModel_eq, hTgt] + . simp [toListModel_eq, hUpd] + +theorem exists_of_toListModel_update_WF (bkts : Buckets α β) (H : bkts.WF) (i d h) : + ∃ l₁ l₂, bkts.toListModel = l₁ ++ bkts.1[i.toNat].toList ++ l₂ + ∧ (bkts.update i d h).toListModel = l₁ ++ d.toList ++ l₂ + ∧ ∀ ab ∈ l₁, ((hash ab.fst).toUSize % bkts.val.size) < i := by + have ⟨bs₁, bs₂, hTgt, hLen, hUpd⟩ := bkts.exists_of_update i d h + refine ⟨bs₁.bind (·.toList), bs₂.bind (·.toList), ?_, ?_, ?_⟩ + . simp [toListModel_eq, hTgt] + . simp [toListModel_eq, hUpd] + . intro ab hMem + have ⟨bkt, hBkt, hAb⟩ := mem_bind.mp hMem + clear hMem + have ⟨⟨j, hJ⟩, hEq⟩ := get_of_mem hBkt + have hJ' : j < bkts.val.size := by + apply Nat.lt_trans hJ + simp [Array.size, hTgt, Nat.lt_add_of_pos_right (Nat.succ_pos _)] + have : ab ∈ (bkts.val[j]).toList := by + suffices bkt = bkts.val[j] by rwa [this] at hAb + have := @List.get_append _ _ (bkts.val[i] :: bs₂) j hJ + dsimp at this + rw [← hEq, ← this, ← get_of_eq hTgt ⟨j, _⟩] + rfl + rwa [hLen, ← H.hash_self _ _ _ this] at hJ + +theorem toListModel_reinsertAux (tgt : Buckets α β) (a : α) (b : β) : + (reinsertAux tgt a b).toListModel ~ (a, b) :: tgt.toListModel := by + unfold reinsertAux + have ⟨l₁, l₂, hTgt, hUpd⟩ := + haveI := mkIdx (hash a) tgt.property + tgt.exists_of_toListModel_update this.1 (.cons a b (tgt.1[this.1.toNat]'this.2)) this.2 + simp [hTgt, hUpd, perm_middle] + +theorem toListModel_foldl_reinsertAux (bkt : List (α × β)) (tgt : Buckets α β) : + (bkt.foldl (init := tgt) fun acc x => reinsertAux acc x.fst x.snd).toListModel + ~ tgt.toListModel ++ bkt := by + induction bkt generalizing tgt with + | nil => simp [Perm.refl] + | cons p ps ih => + refine Perm.trans (ih _) ?_ + refine Perm.trans (Perm.append_right ps (toListModel_reinsertAux _ _ _)) ?_ + rw [cons_append] + refine Perm.trans (Perm.symm perm_middle) ?_ + apply Perm.append_left _ (Perm.refl _) + +theorem toListModel_expand (size : Nat) (bkts : Buckets α β) : + (expand size bkts).buckets.toListModel ~ bkts.toListModel := by + refine (go _ _ _).trans ?_ + rw [toListModel_mk, toListModel_eq] + simp [Perm.refl] +where + go (i : Nat) (src : Array (AssocList α β)) (target : Buckets α β) : + (expand.go i src target).toListModel + ~ (src.data.drop i).foldl (init := target.toListModel) (fun a b => a ++ b.toList) := by + unfold expand.go; split + case inl hI => + refine (go (i +1) _ _).trans ?_ + have h₀ : (src.data.set i AssocList.nil).drop (i + 1) = src.data.drop (i + 1) := by + apply drop_ext + intro j hJ + apply get?_set_ne _ _ (Nat.ne_of_lt <| Nat.lt_of_succ_le hJ) + have h₁ : (drop i src.data).bind (·.toList) = src.data[i].toList + ++ (drop (i + 1) src.data).bind (·.toList) := by + have : i < src.data.length := by simp [hI] + simp [drop_eq_cons_get _ _ this] + simp [h₀, h₁] + rw [← append_assoc] + refine Perm.append ?_ (Perm.refl _) + refine Perm.trans (toListModel_foldl_reinsertAux (AssocList.toList src[i]) _) ?_ + exact Perm.refl _ + case inr hI => + have : src.data.length ≤ i := by simp [Nat.le_of_not_lt, hI] + simp [Perm.refl, drop_eq_nil_of_le this] + termination_by _ i src _ => src.size - i + +end Buckets + +theorem findEntry?_eq (m : Imp α β) (H : m.buckets.WF) (a : α) + : m.findEntry? a = m.buckets.toListModel.find? (·.1 == a) := by + have hPairwiseBkt : + haveI := mkIdx (hash a) m.buckets.property + Pairwise (fun p q => p.1 == a → q.1 != a) (m.buckets.val[this.1]'this.2).toList := + by apply Buckets.Pairwise_bne_bucket' m.buckets H + apply Option.ext + intro (a', b) + simp only [Option.mem_def, findEntry?, Imp.findEntry?, AssocList.findEntry?_eq, + find?_eq_some_of_unique (Buckets.Pairwise_bne_toListModel' m.buckets H a), + find?_eq_some_of_unique hPairwiseBkt, + and_congr_left_iff] + intro hBeq + have : hash a' = hash a := LawfulHashable.hash_eq hBeq + simp [Buckets.mem_toListModel_iff_mem_bucket m.buckets H, mkIdx, this] + +theorem eraseP_toListModel_of_not_contains (m : Imp α β) (H : m.buckets.WF) (a : α) : + haveI := mkIdx (hash a) m.buckets.property + ¬(m.buckets.val[this.1.toNat]'this.2).contains a → + m.buckets.toListModel.eraseP (·.1 == a) = m.buckets.toListModel := by + intro hContains + apply eraseP_of_forall_not + intro ab hMem hEq + have : + haveI := mkIdx (hash a) m.buckets.property + (m.buckets.val[this.1.toNat]'this.2).contains a := by + simp only [AssocList.contains_eq, List.any_eq_true, mkIdx, ← LawfulHashable.hash_eq hEq] + exact ⟨ab, (Buckets.mem_toListModel_iff_mem_bucket m.buckets H ab).mp hMem, hEq⟩ + contradiction + +theorem toListModel_insert_perm (m : Imp α β) (H : m.buckets.WF) (a : α) (b : β) : + (m.insert a b).buckets.toListModel ~ (a, b) :: m.buckets.toListModel.eraseP (·.1 == a) := by + dsimp [insert, cond]; split + next hContains => + have ⟨l₁, l₂, hTgt, hUpd, hProp⟩ := + haveI := mkIdx (hash a) m.buckets.property + m.buckets.exists_of_toListModel_update_WF H this.1 + ((m.buckets.1[this.1.toNat]'this.2).replace a b) this.2 + rw [hUpd, hTgt] + have hL₁ : ∀ ab ∈ l₁, ¬(ab.fst == a) := fun ab h hEq => + Nat.ne_of_lt (LawfulHashable.hash_eq hEq ▸ hProp ab h) rfl + have ⟨p, hMem, hP⟩ := any_eq_true.mp (AssocList.contains_eq a _ ▸ hContains) + simp [eraseP_append_right _ hL₁, + eraseP_append_left (p := fun ab => ab.fst == a) hP _ hMem] + -- begin cursed manual proofs + refine Perm.trans ?_ perm_middle + refine Perm.append (Perm.refl _) ?_ + rw [← cons_append] + refine Perm.append ?_ (Perm.refl _) + refine Perm.trans + (replaceF_of_unique + (b := (a, b)) + (f := fun a_1 => bif a_1.fst == a then some (a, b) else none) + hMem + (by simp [hP]) + (by + refine Pairwise.imp ?_ (Buckets.Pairwise_bne_bucket' m.buckets H _ a) + intro p q h hSome + dsimp at * + cases hEq: p.fst == a with + | false => cases hEq ▸ hSome + | true => + have : (q.fst == a) = false := + Bool.eq_false_iff.mpr (Bool.bne_iff_not_beq.mp <| h hEq) + simp [this])) + ?_ + apply List.Perm.of_eq + congr + apply funext + intro x + cases h : x.fst == a <;> simp [h] + -- end cursed manual proofs + + next hContains => + rw [eraseP_toListModel_of_not_contains m H a (Bool.eq_false_iff.mp hContains)] + split + -- TODO(WN): how to merge the two branches below? They are identical except for the initial + -- `refine` + next => + have ⟨l₁, l₂, hTgt, hUpd⟩ := + haveI := mkIdx (hash a) m.buckets.property + m.buckets.exists_of_toListModel_update this.1 + ((m.buckets.1[this.1.toNat]'this.2).cons a b) this.2 + simp [hTgt, hUpd, perm_middle] + next => + refine Perm.trans (Buckets.toListModel_expand _ _) ?_ + have ⟨l₁, l₂, hTgt, hUpd⟩ := + haveI := mkIdx (hash a) m.buckets.property + m.buckets.exists_of_toListModel_update this.1 + ((m.buckets.1[this.1.toNat]'this.2).cons a b) this.2 + simp [hTgt, hUpd, perm_middle] + +theorem toListModel_erase (m : Imp α β) (H : m.buckets.WF) (a : α) : + (m.erase a).buckets.toListModel = m.buckets.toListModel.eraseP (·.1 == a) := by + dsimp [erase, cond]; split + next hContains => + have ⟨l₁, l₂, hTgt, hUpd, hProp⟩ := + haveI := mkIdx (hash a) m.buckets.property + m.buckets.exists_of_toListModel_update_WF H this.1 + ((m.buckets.1[this.1.toNat]'this.2).erase a) this.2 + rw [hTgt, hUpd] + have hL₁ : ∀ ab ∈ l₁, ¬(ab.fst == a) := fun ab h hEq => + Nat.ne_of_lt (LawfulHashable.hash_eq hEq ▸ hProp ab h) rfl + have ⟨p, hMem, hP⟩ := any_eq_true.mp (AssocList.contains_eq a _ ▸ hContains) + simp [eraseP_append_right _ hL₁, eraseP_append_left (p := fun ab => ab.fst == a) hP _ hMem] + next hContains => + rw [eraseP_toListModel_of_not_contains m H a (Bool.eq_false_iff.mp hContains)] + +theorem eraseP_toListModel (m : Imp α β) (H : m.buckets.WF) (a : α) : + m.buckets.toListModel.eraseP (·.1 == a) = m.buckets.toListModel.filter (·.1 != a) := by + apply List.eraseP_eq_filter_of_unique + apply List.Pairwise.imp ?_ (Buckets.Pairwise_bne_toListModel _ H) + intro (a₁, _) (a₂, _) hA₁Bne hA₁Beq + rw [Bool.not_eq_true_iff_ne_true, ← Bool.bne_iff_not_beq] + exact beq_nonsense_1 hA₁Bne hA₁Beq + +theorem toListModel_insert_perm' (m : Imp α β) (H : m.buckets.WF) (a : α) (b : β) : + (m.insert a b).buckets.toListModel ~ (a, b) :: m.buckets.toListModel.filter (·.1 != a) := + eraseP_toListModel m H a ▸ toListModel_insert_perm m H a b + +theorem toListModel_erase' (m : Imp α β) (H : m.buckets.WF) (a : α) : + (m.erase a).buckets.toListModel = m.buckets.toListModel.filter (·.1 != a) := + eraseP_toListModel m H a ▸ toListModel_erase m H a + +/-! ## Useful high-level theorems -/ + +theorem findEntry?_insert {a a' b} {m : Imp α β} (H : m.WF) : + a == a' → (m.insert a b).findEntry? a' = some (a, b) := by + intro hEq + have hWF := WF_iff.mp H |>.right + have hInsWF : (m.insert a b).buckets.WF := H.insert.out |>.right + rw [findEntry?_eq _ hInsWF] + have hPerm := toListModel_insert_perm m hWF a b + have hUniq : (insert m a b).buckets.toListModel.unique (·.1 == a') := + Buckets.unique_toListModel _ hInsWF a' + simp [find?_eq_of_perm_of_unique hPerm hUniq, hEq] + +theorem findEntry?_insert_of_ne {a a'} {m : Imp α β} (H : m.WF) : + a != a' → (m.insert a b).findEntry? a' = m.findEntry? a' := by + intro hNe + have hWF := WF_iff.mp H |>.right + have hInsWF : (m.insert a b).buckets.WF := H.insert.out |>.right + have hPerm := toListModel_insert_perm' m hWF a b + have hUniq : (insert m a b).buckets.toListModel.unique (·.1 == a') := + Buckets.unique_toListModel _ hInsWF a' + rw [findEntry?_eq _ hWF, findEntry?_eq _ hInsWF, + find?_eq_of_perm_of_unique hPerm hUniq, + find?_cons_of_neg _ ?ne] + case ne => exact Bool.bne_iff_not_beq.mp hNe + exact find?_filter _ _ _ fun _ => beq_nonsense_3 hNe + +theorem findEntry?_erase {a a'} {m : Imp α β} (H : m.WF) : + a == a' → (m.erase a).findEntry? a' = none := by + intro hEq + have hWF := WF_iff.mp H |>.right + have hErsWF : (m.erase a).buckets.WF := H.erase.out |>.right + rw [findEntry?_eq _ hErsWF, toListModel_erase' m hWF a, + find?_filter' _ _ _ ?ne] + case ne => + intro _ h + simp only [Bool.bnot_eq_to_not_eq, Bool.not_eq_true, Bool.bne_eq_false] + exact PartialEquivBEq.trans h (PartialEquivBEq.symm hEq) + +end Imp + +theorem toList_eq_reverse_toListModel (m : HashMap α β) : + m.toList = m.val.buckets.toListModel.reverse := by + simp only [toList, Imp.Buckets.toListModel, fold, Imp.fold, Array.foldl_eq_foldl_data, + AssocList.foldl_eq, List.foldl_cons_fn] + suffices ∀ (l₁ : List (AssocList α β)) (l₂ : List (α × β)), + l₁.foldl (init := l₂.reverse) (fun d b => b.toList.reverse ++ d) = + (l₁.foldl (init := l₂) fun acc bkt => acc ++ bkt.toList).reverse by + apply this (l₂ := []) + intro l₁ + induction l₁ with + | nil => intro; rfl + | cons a as ih => + intro l₂ + simp only [List.foldl, ← List.reverse_append, ih] + +/-! `empty` -/ + +theorem isEmpty_empty : (HashMap.empty : HashMap α β).isEmpty := + sorry + +/-! `findEntry?` -/ + +@[simp] +theorem findEntry?_of_isEmpty (m : HashMap α β) (a : α) : m.isEmpty → m.findEntry? a = none := + sorry + +@[simp] +theorem findEntry?_empty (a : α) : (HashMap.empty : HashMap α β).findEntry? a = none := + findEntry?_of_isEmpty _ a isEmpty_empty + +theorem findEntry?_insert {a a'} (m : HashMap α β) (b) : + a == a' → (m.insert a b).findEntry? a' = some (a, b) := + m.val.findEntry?_insert m.property + +theorem findEntry?_insert_of_ne {a a'} (m : HashMap α β) (b) : + a != a' → (m.insert a b).findEntry? a' = m.findEntry? a' := + m.val.findEntry?_insert_of_ne m.property + +theorem findEntry?_erase {a a'} (m : HashMap α β) : a == a' → (m.erase a).findEntry? a' = none := + m.val.findEntry?_erase m.property + +theorem ext_findEntry? (m₁ m₂ : HashMap α β) : (∀ a, m₁.findEntry? a = m₂.findEntry? a) → m₁ = m₂ := + sorry + +/-! `find?` -/ + +theorem find?_eq (m : HashMap α β) (a : α) : m.find? a = (m.findEntry? a).map (·.2) := + AssocList.find?_eq_findEntry? _ _ + +theorem find?_of_isEmpty (m : HashMap α β) (a : α) : m.isEmpty → m.find? a = none := + sorry + +@[simp] +theorem find?_empty (a : α) : (HashMap.empty : HashMap α β).find? a = none := + find?_of_isEmpty _ a isEmpty_empty + +theorem find?_insert {a a'} (m : HashMap α β) (b) : a == a' → (m.insert a b).find? a' = some b := + fun h => by simp [find?_eq, findEntry?_insert m b h] + +theorem find?_insert_of_ne {a a'} (m : HashMap α β) (b) : + a != a' → (m.insert a b).find? a' = m.find? a' := + fun h => by simp [find?_eq, findEntry?_insert_of_ne m b h] + +theorem find?_erase {a a'} (m : HashMap α β) : a == a' → (m.erase a).find? a' = none := + fun h => by simp [find?_eq, findEntry?_erase m h] + +/-! `insert` -/ + +theorem insert_comm [LawfulBEq α] (m : HashMap α β) (a₁ a₂ : α) (b : β) : + (m.insert a₁ b).insert a₂ b = (m.insert a₂ b).insert a₁ b := by + apply ext_findEntry? + intro a + cases Bool.beq_or_bne a₁ a <;> cases Bool.beq_or_bne a₂ a <;> + simp_all [findEntry?_insert, findEntry?_insert_of_ne] + +/-! `contains` -/ + +theorem contains_iff (m : HashMap α β) (a : α) : + m.contains a ↔ ∃ b, m.find? a = some b := + sorry + +theorem not_contains_iff (m : HashMap α β) (a : α) : + m.contains a = false ↔ m.find? a = none := by + have := contains_iff m a + apply Iff.intro + . intro h; cases h' : find? m a <;> simp_all + . intro h; simp_all + +theorem not_contains_of_isEmpty (m : HashMap α β) (a : α) : m.isEmpty → m.contains a = false := + fun h => not_contains_iff _ _ |>.mpr (find?_of_isEmpty m a h) + +@[simp] +theorem not_contains_empty (β) (a : α) : (empty : HashMap α β).contains a = false := + not_contains_of_isEmpty _ a isEmpty_empty + +theorem contains_insert (m : HashMap α β) (a a' : α) (b : β) : + (m.insert a b).contains a' ↔ (m.contains a' ∨ a == a') := by + simp only [contains_iff] + refine ⟨?mp, fun h => h.elim ?mpr₁ ?mpr₂⟩ + case mp => + intro ⟨b, hFind⟩ + cases Bool.beq_or_bne a a' + case inl h => + exact Or.inr h + case inr h => + rw [find?_insert_of_ne _ _ h] at hFind + exact Or.inl ⟨b, hFind⟩ + case mpr₁ => + intro ⟨b, hFind⟩ + cases Bool.beq_or_bne a a' + case inl h => + rw [find?_insert _ _ h] + exact ⟨_, rfl⟩ + case inr h => + rw [find?_insert_of_ne _ _ h] + exact ⟨_, hFind⟩ + case mpr₂ => + intro hEq + rw [find?_insert _ _ hEq] + exact ⟨_, rfl⟩ + +/-! `fold` -/ + +/-- If an entry appears in the map, it will appear "last" in a commutative `fold` over the map. -/ +theorem fold_of_mapsTo_of_comm [LawfulBEq α] (m : HashMap α β) (f : δ → α → β → δ) (init : δ) : + m.find? a = some b → + -- NOTE: This could be strengthened by assuming m.find? a₁ = some b₁ + -- and ditto for a₂, b₂ in the ∀ hypothesis + (∀ d a₁ b₁ a₂ b₂, f (f d a₁ b₁) a₂ b₂ = f (f d a₂ b₂) a₁ b₁) → + -- TODO: Might also have to assume assoc + ∃ d, m.fold f init = f d a b := + sorry + +/-- Analogous to `List.foldlRecOn`. -/ +def foldRecOn {C : δ → Sort _} (m : HashMap α β) (f : δ → α → β → δ) (init : δ) (hInit : C init) + (hf : ∀ d a b, C d → m.find? a = some b → C (f d a b)) : C (m.fold f init) := + sorry + +end HashMap diff --git a/Experiments/CPOG/Data/HashMap/WF.lean b/Experiments/CPOG/Data/HashMap/WF.lean new file mode 100644 index 0000000..65b07db --- /dev/null +++ b/Experiments/CPOG/Data/HashMap/WF.lean @@ -0,0 +1,348 @@ +/- +Copyright (c) 2022 Mario Carneiro. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Mario Carneiro +-/ +import ProofChecker.Data.HashMap.Basic +import Std.Data.List.Lemmas +import Std.Data.Array.Lemmas + +namespace HashMap +open Std +namespace Imp + +attribute [-simp] Bool.not_eq_true + +namespace Buckets + +@[ext] protected theorem ext : ∀ {b₁ b₂ : Buckets α β}, b₁.1.data = b₂.1.data → b₁ = b₂ + | ⟨⟨_⟩, _⟩, ⟨⟨_⟩, _⟩, rfl => rfl + +theorem update_data (self : Buckets α β) (i d h) : + (self.update i d h).1.data = self.1.data.set i.toNat d := rfl + +@[simp] theorem update_size (self : Buckets α β) (i d h) : + (self.update i d h).1.size = self.1.size := Array.size_uset .. + +/-- This theorem, small it may seem, can solve many problems. Apply whenever possible. -/ +theorem exists_of_update (self : Buckets α β) (i d h) : + ∃ l₁ l₂, self.1.data = l₁ ++ self.1[i.toNat] :: l₂ ∧ List.length l₁ = i.toNat ∧ + (self.update i d h).1.data = l₁ ++ d :: l₂ := by + simp [Array.getElem_eq_data_get]; exact List.exists_of_set' h + +theorem size_eq (data : Buckets α β) : + size data = .sum (data.1.data.map (·.toList.length)) := rfl + +theorem mk_size (h) : (mk n h : Buckets α β).size = 0 := by + simp [Buckets.size_eq, Buckets.mk, mkArray]; clear h + induction n <;> simp [*] + +theorem WF.mk' [BEq α] [Hashable α] (h) : (Buckets.mk n h : Buckets α β).WF := by + refine ⟨fun _ h => ?_, fun i h => ?_⟩ + · simp [Buckets.mk, empty', mkArray, List.mem_replicate] at h + simp [h, List.Pairwise.nil] + · simp [Buckets.mk, empty', mkArray, Array.getElem_eq_data_get, AssocList.All] + +theorem WF.update [BEq α] [Hashable α] {buckets : Buckets α β} {i d h} (H : buckets.WF) + (h₁ : ∀ [PartialEquivBEq α] [LawfulHashable α], + (buckets.1[i].toList.Pairwise fun a b => ¬(a.1 == b.1)) → + d.toList.Pairwise fun a b => ¬(a.1 == b.1)) + (h₂ : (buckets.1[i].All fun k _ => ((hash k).toUSize % buckets.1.size).toNat = i.toNat) → + d.All fun k _ => ((hash k).toUSize % buckets.1.size).toNat = i.toNat) : + (buckets.update i d h).WF := by + refine ⟨fun l hl => ?_, fun i hi p hp => ?_⟩ + · exact match List.mem_or_eq_of_mem_set hl with + | .inl hl => H.1 _ hl + | .inr rfl => h₁ (H.1 _ (Array.getElem_mem_data ..)) + · revert hp; simp [update_data, Array.getElem_eq_data_get, List.get_set] + split <;> intro hp + · next eq => exact eq ▸ h₂ (H.2 _ _) _ hp + · simp at hi; exact H.2 i hi _ hp + +end Buckets + +theorem reinsertAux_size [Hashable α] (data : Buckets α β) (a : α) (b : β) : + (reinsertAux data a b).size = data.size.succ := by + simp [Buckets.size_eq, reinsertAux] + refine have ⟨l₁, l₂, h₁, _, eq⟩ := Buckets.exists_of_update ..; eq ▸ ?_ + simp [h₁, Nat.succ_add]; rfl + +theorem reinsertAux_WF [BEq α] [Hashable α] {data : Buckets α β} {a : α} {b : β} (H : data.WF) + (h₁ : ∀ [PartialEquivBEq α] [LawfulHashable α], + haveI := mkIdx (hash a) data.2 + (data.val[this.1]'this.2).All fun x _ => ¬(a == x)) : + (reinsertAux data a b).WF := + H.update (.cons h₁) fun + | _, _, .head .. => rfl + | H, _, .tail _ h => H _ h + +theorem expand_size [Hashable α] {buckets : Buckets α β} : + (expand sz buckets).buckets.size = buckets.size := by + rw [expand, go] + · rw [Buckets.mk_size]; simp [Buckets.size] + · intro. +where + go (i source) (target : Buckets α β) (hs : ∀ j < i, source.data.getD j .nil = .nil) : + (expand.go i source target).size = + .sum (source.data.map (·.toList.length)) + target.size := by + unfold expand.go; split + · next H => + refine (go (i+1) _ _ fun j hj => ?a).trans ?b <;> simp + · case a => + simp [List.getD_eq_get?, List.get?_set]; split + · cases List.get? .. <;> rfl + · next H => exact hs _ (Nat.lt_of_le_of_ne (Nat.le_of_lt_succ hj) (Ne.symm H)) + · case b => + refine have ⟨l₁, l₂, h₁, _, eq⟩ := List.exists_of_set' H; eq ▸ ?_ + simp [h₁, Buckets.size_eq] + rw [Nat.add_assoc, Nat.add_assoc, Nat.add_assoc]; congr 1 + (conv => rhs; rw [Nat.add_left_comm]); congr 1 + rw [← Array.getElem_eq_data_get] + have := @reinsertAux_size α β _; simp [Buckets.size] at this + induction source[i].toList generalizing target <;> simp [*, Nat.succ_add]; rfl + · next H => + rw [(_ : Nat.sum _ = 0), Nat.zero_add] + rw [← (_ : source.data.map (fun _ => .nil) = source.data)] + · simp; induction source.data <;> simp [*] + refine List.ext_get (by simp) fun j h₁ h₂ => ?_ + simp + have := (hs j (Nat.lt_of_lt_of_le h₂ (Nat.not_lt.1 H))).symm + rwa [List.getD_eq_get?, List.get?_eq_get, Option.getD_some] at this +termination_by go i source _ _ => source.size - i + +theorem expand_WF.foldl [BEq α] [Hashable α] (rank : α → Nat) {l : List (α × β)} {i : Nat} + (hl₁ : ∀ [PartialEquivBEq α] [LawfulHashable α], l.Pairwise fun a b => ¬(a.1 == b.1)) + (hl₂ : ∀ x ∈ l, rank x.1 = i) + {target : Buckets α β} (ht₁ : target.WF) + (ht₂ : ∀ bucket ∈ target.1.data, + bucket.All fun k _ => rank k ≤ i ∧ + ∀ [PartialEquivBEq α] [LawfulHashable α], ∀ x ∈ l, ¬(x.1 == k)) : + (l.foldl (fun d x => reinsertAux d x.1 x.2) target).WF ∧ + ∀ bucket ∈ (l.foldl (fun d x => reinsertAux d x.1 x.2) target).1.data, + bucket.All fun k _ => rank k ≤ i := by + induction l generalizing target with + | nil => exact ⟨ht₁, fun _ h₁ _ h₂ => (ht₂ _ h₁ _ h₂).1⟩ + | cons _ _ ih => + simp at hl₁ hl₂ ht₂ + refine ih hl₁.2 hl₂.2 + (reinsertAux_WF ht₁ fun _ h => (ht₂ _ (Array.getElem_mem_data ..) _ h).2.1) + (fun _ h => ?_) + simp [reinsertAux, Buckets.update] at h + match List.mem_or_eq_of_mem_set h with + | .inl h => + intro _ hf + have ⟨h₁, h₂⟩ := ht₂ _ h _ hf + exact ⟨h₁, h₂.2⟩ + | .inr h => subst h; intro + | _, .head .. => + exact ⟨hl₂.1 ▸ Nat.le_refl _, fun _ h h' => hl₁.1 _ h (PartialEquivBEq.symm h')⟩ + | _, .tail _ h => + have ⟨h₁, h₂⟩ := ht₂ _ (Array.getElem_mem_data ..) _ h + exact ⟨h₁, h₂.2⟩ + +theorem expand_WF [BEq α] [Hashable α] {buckets : Buckets α β} (H : buckets.WF) : + (expand sz buckets).buckets.WF := + go _ H.1 H.2 ⟨.mk' _, fun _ _ _ _ => by simp_all [Buckets.mk, List.mem_replicate]⟩ +where + go (i) {source : Array (AssocList α β)} + (hs₁ : ∀ [LawfulHashable α] [PartialEquivBEq α], ∀ bucket ∈ source.data, + bucket.toList.Pairwise fun a b => ¬(a.1 == b.1)) + (hs₂ : ∀ (j : Nat) (h : j < source.size), + source[j].All fun k _ => ((hash k).toUSize % source.size).toNat = j) + {target : Buckets α β} (ht : target.WF ∧ ∀ bucket ∈ target.1.data, + bucket.All fun k _ => ((hash k).toUSize % source.size).toNat < i) : + (expand.go i source target).WF := by + unfold expand.go; split + · next H => + refine go (i+1) (fun _ hl => ?_) (fun i h => ?_) ?_ + · match List.mem_or_eq_of_mem_set hl with + | .inl hl => exact hs₁ _ hl + | .inr e => exact e ▸ .nil + · simp [Array.getElem_eq_data_get, List.get_set]; split + · intro. + · exact hs₂ _ (by simp_all) + · let rank (k : α) := ((hash k).toUSize % source.size).toNat + have := expand_WF.foldl rank ?_ (hs₂ _ H) ht.1 (fun _ h₁ _ h₂ => ?_) + · simp; exact ⟨this.1, fun _ h₁ _ h₂ => Nat.lt_succ_of_le (this.2 _ h₁ _ h₂)⟩ + · exact hs₁ _ (Array.getElem_mem_data ..) + · have := ht.2 _ h₁ _ h₂ + refine ⟨Nat.le_of_lt this, fun _ h h' => Nat.ne_of_lt this ?_⟩ + exact LawfulHashable.hash_eq h' ▸ hs₂ _ H _ h + · exact ht.1 +termination_by go i source _ _ _ _ => source.size - i + +theorem insert_size [BEq α] [Hashable α] {m : Imp α β} {k v} + (h : m.size = m.buckets.size) : + (insert m k v).size = (insert m k v).buckets.size := by + dsimp [insert, cond]; split + · unfold Buckets.size + refine have ⟨_, _, h₁, _, eq⟩ := Buckets.exists_of_update ..; eq ▸ ?_ + simp [h, h₁, Buckets.size_eq] + split + · unfold Buckets.size + refine have ⟨_, _, h₁, _, eq⟩ := Buckets.exists_of_update ..; eq ▸ ?_ + simp [h, h₁, Buckets.size_eq, Nat.succ_add]; rfl + · rw [expand_size]; simp [h, expand, Buckets.size] + refine have ⟨_, _, h₁, _, eq⟩ := Buckets.exists_of_update ..; eq ▸ ?_ + simp [h₁, Buckets.size_eq, Nat.succ_add]; rfl + +private theorem mem_replaceF {l : List (α × β)} {x : α × β} {p : α × β → Bool} : + x ∈ (l.replaceF fun a => bif p a then some (k, v) else none) → x.1 = k ∨ x ∈ l := by + induction l with + | nil => exact .inr + | cons a l ih => + simp; generalize e : cond .. = z; revert e + unfold cond; split <;> (intro h; subst h; simp) + · intro + | .inl eq => exact eq ▸ .inl rfl + | .inr h => exact .inr (.inr h) + · intro + | .inl eq => exact .inr (.inl eq) + | .inr h => exact (ih h).imp_right .inr + +private theorem pairwise_replaceF [BEq α] [PartialEquivBEq α] + {l : List (α × β)} {x : α × β} (hx₁ : x ∈ l) (hx₂ : x.fst == k) + (H : l.Pairwise fun a b => ¬(a.fst == b.fst)) : + (l.replaceF fun a => bif a.fst == k then some (k, v) else none) + |>.Pairwise fun a b => ¬(a.fst == b.fst) := by + induction hx₁ with + | head => simp_all; exact (H.1 · · ∘ PartialEquivBEq.trans hx₂) + | tail _ _ ih => + simp at H ⊢ + generalize e : cond .. = z; revert e + unfold cond; split <;> (intro h; subst h; simp) + · next e => exact ⟨(H.1 · · ∘ PartialEquivBEq.trans e), H.2⟩ + · next e => + refine ⟨fun a h => ?_, ih H.2⟩ + match mem_replaceF h with + | .inl eq => exact eq ▸ ne_true_of_eq_false e + | .inr h => exact H.1 a h + +theorem insert_WF [BEq α] [Hashable α] {m : Imp α β} {k v} + (h : m.buckets.WF) : (insert m k v).buckets.WF := by + dsimp [insert, cond]; split + · next h₁ => + simp at h₁; have ⟨x, hx₁, hx₂⟩ := h₁ + refine h.update (fun H => ?_) (fun H a h => ?_) + · simp; exact pairwise_replaceF hx₁ hx₂ H + · simp [AssocList.All] at H h ⊢ + match mem_replaceF h with + | .inl rfl => rfl + | .inr h => exact H _ h + · next h₁ => + rw [Bool.eq_false_iff] at h₁; simp at h₁ + suffices _ by split <;> [exact this, refine expand_WF this] + refine h.update (.cons ?_) (fun H a h => ?_) + · exact fun a h h' => h₁ a h (PartialEquivBEq.symm h') + · cases h with + | head => rfl + | tail _ h => exact H _ h + +theorem erase_size [BEq α] [Hashable α] {m : Imp α β} {k} + (h : m.size = m.buckets.size) : + (erase m k).size = (erase m k).buckets.size := by + dsimp [erase, cond]; split + · next H => + simp [h, Buckets.size] + refine have ⟨_, _, h₁, _, eq⟩ := Buckets.exists_of_update ..; eq ▸ ?_ + simp [h, h₁, Buckets.size_eq] + rw [(_ : List.length _ = _ + 1), Nat.add_right_comm]; {rfl} + clear h₁ eq + simp [AssocList.contains_eq] at H + have ⟨a, h₁, h₂⟩ := H + refine have ⟨_, _, _, _, _, h, eq⟩ := List.exists_of_eraseP h₁ h₂; eq ▸ ?_ + simp [h]; rfl + · exact h + +theorem erase_WF [BEq α] [Hashable α] {m : Imp α β} {k} + (h : m.buckets.WF) : (erase m k).buckets.WF := by + dsimp [erase, cond]; split + · refine h.update (fun H => ?_) (fun H a h => ?_) <;> simp at h ⊢ + · simp; exact H.sublist (List.eraseP_sublist _) + · exact H _ (List.mem_of_mem_eraseP h) + · exact h + +theorem WF.out [BEq α] [Hashable α] {m : Imp α β} (h : m.WF) : + m.size = m.buckets.size ∧ m.buckets.WF := by + induction h with + | mk h₁ h₂ => exact ⟨h₁, h₂⟩ + | @empty' _ h => exact ⟨(Buckets.mk_size h).symm, .mk' h⟩ + | insert _ ih => exact ⟨insert_size ih.1, insert_WF ih.2⟩ + | erase _ ih => exact ⟨erase_size ih.1, erase_WF ih.2⟩ + +theorem WF_iff [BEq α] [Hashable α] {m : Imp α β} : + m.WF ↔ m.size = m.buckets.size ∧ m.buckets.WF := + ⟨(·.out), fun ⟨h₁, h₂⟩ => .mk h₁ h₂⟩ + +theorem WF.mapVal {α β γ} {f : α → β → γ} [BEq α] [Hashable α] + {m : Imp α β} (H : WF m) : WF (mapVal f m) := by + have ⟨h₁, h₂⟩ := H.out + simp [Imp.mapVal, Buckets.mapVal, WF_iff, h₁]; refine ⟨?_, ?_, fun i h => ?_⟩ + · simp [Buckets.size]; congr; funext l; simp + · simp [List.forall_mem_map_iff, List.pairwise_map] + exact fun _ => h₂.distinct _ + · simp [AssocList.All, List.forall_mem_map_iff] at h ⊢ + exact h₂.2 _ h + +theorem WF.filterMap {α β γ} {f : α → β → Option γ} [BEq α] [Hashable α] + {m : Imp α β} (H : WF m) : WF (filterMap f m) := by + let g₁ (l : AssocList α β) := l.toList.filterMap (fun x => (f x.1 x.2).map (x.1, ·)) + have H1 (l n acc) : filterMap.go f acc l n = + (((g₁ l).reverse ++ acc.toList).toAssocList, ⟨n.1 + (g₁ l).length⟩) := by + induction l generalizing n acc with simp [filterMap.go, *] + | cons a b l => match f a b with + | none => rfl + | some c => simp; rw [Nat.add_right_comm]; rfl + let g l := (g₁ l).reverse.toAssocList + let M := StateT (ULift Nat) Id + have H2 (l : List (AssocList α β)) n : + l.mapM (m := M) (filterMap.go f .nil) n = + (l.map g, ⟨n.1 + .sum ((l.map g).map (·.toList.length))⟩) := by + induction l generalizing n with + | nil => rfl + | cons l L IH => simp [bind, StateT.bind, IH, H1, Nat.add_assoc]; rfl + have H3 (l : List _) : + (l.filterMap (fun (a, b) => (f a b).map (a, ·))).map (fun a => a.fst) + |>.Sublist (l.map (·.1)) := by + induction l with + | nil => exact .slnil + | cons a l ih => + simp; exact match f a.1 a.2 with + | none => .cons _ ih + | some b => .cons₂ _ ih + suffices ∀ bk sz (h : bk.length.isPowerOfTwo), + m.buckets.val.mapM (m := M) (filterMap.go f .nil) ⟨0⟩ = (⟨bk⟩, ⟨sz⟩) → + WF ⟨sz, ⟨bk⟩, h⟩ from this _ _ _ rfl + simp [Array.mapM_eq_mapM_data, bind, StateT.bind, H2] + intro bk sz h e'; cases e' + refine .mk (by simp [Buckets.size]) ⟨?_, fun i h => ?_⟩ + · simp [List.forall_mem_map_iff] + refine fun l h => (List.pairwise_reverse.2 ?_).imp (mt PartialEquivBEq.symm) + have := H.out.2.1 _ h + rw [← List.pairwise_map (R := (¬ · == ·))] at this ⊢ + exact this.sublist (H3 l.toList) + · simp [Array.getElem_eq_data_get] at h ⊢ + have := H.out.2.2 _ h + simp [AssocList.All] at this ⊢ + rw [← List.forall_mem_map_iff + (P := fun a => ((hash a).toUSize % m.buckets.val.data.length).toNat = i)] at this ⊢ + exact fun _ h' => this _ ((H3 _).subset h') + +end Imp + +variable {_ : BEq α} {_ : Hashable α} + +/-- Map a function over the values in the map. -/ +@[inline] def mapVal (f : α → β → γ) (self : HashMap α β) : HashMap α γ := + ⟨self.1.mapVal f, self.2.mapVal⟩ + +/-- +Applies `f` to each key-value pair `a, b` in the map. If it returns `some c` then +`a, c` is pushed into the new map; else the key is removed from the map. +-/ +@[inline] def filterMap (f : α → β → Option γ) (self : HashMap α β) : HashMap α γ := + ⟨self.1.filterMap f, self.2.filterMap⟩ + +/-- Constructs a map with the set of all pairs `a, b` such that `f` returns true. -/ +@[inline] def filter (f : α → β → Bool) (self : HashMap α β) : HashMap α β := + self.filterMap fun a b => bif f a b then some b else none diff --git a/Experiments/CPOG/Data/HashSet.lean b/Experiments/CPOG/Data/HashSet.lean new file mode 100644 index 0000000..4636958 --- /dev/null +++ b/Experiments/CPOG/Data/HashSet.lean @@ -0,0 +1,259 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import Mathlib.Data.Finset.Basic + +import ProofChecker.Data.HashMap.Lemmas + +def HashSet (α : Type) [BEq α] [Hashable α] := HashMap α Unit + +namespace HashSet + +variable {α : Type} [BEq α] [Hashable α] + +def empty (α : Type) [BEq α] [Hashable α] : HashSet α := + HashMap.empty + +def isEmpty (s : HashSet α) : Bool := + HashMap.isEmpty s + +def insert (s : HashSet α) (a : α) : HashSet α := + HashMap.insert s a () + +def singleton (a : α) : HashSet α := + empty α |>.insert a + +def contains (s : HashSet α) (a : α) : Bool := + HashMap.contains s a + +def union (s t : HashSet α) : HashSet α := + HashMap.fold (init := s) (fun acc a _ => acc.insert a) t + +def inter (s t : HashSet α) : HashSet α := + HashMap.fold (init := empty α) (fun acc a _ => + if s.contains a then acc.insert a else acc) t + +variable [DecidableEq α] + +def toFinset (s : HashSet α) : Finset α := + HashMap.fold (init := ∅) (fun X a _ => Insert.insert a X) s + +variable [LawfulBEq α] [HashMap.LawfulHashable α] + +theorem toFinset_sub (s : HashSet α) (a : α) : a ∈ s.toFinset → s.contains a := by + dsimp [toFinset] + apply HashMap.foldRecOn + (C := fun acc => a ∈ acc → s.contains a) + (hInit := by simp) + simp only [Finset.mem_insert] + intro _ a _ ih hFind hMem + cases hMem with + | inl h => + apply HashMap.contains_iff _ _ |>.mpr + exact h ▸ ⟨_, hFind⟩ + | inr h => exact ih h + +theorem sub_toFinset (s : HashSet α) (a : α) : s.contains a → a ∈ s.toFinset := by + dsimp [toFinset, contains] + intro hContains + have ⟨_, hFind⟩ := HashMap.contains_iff _ _ |>.mp hContains + have ⟨_, hEq⟩ := HashMap.fold_of_mapsTo_of_comm s (fun (X : Finset α) a _ => Insert.insert a X) ∅ + hFind ?comm + case comm => + intros + ext + aesop + simp [hEq] + +theorem mem_toFinset (s : HashSet α) (a : α) : a ∈ s.toFinset ↔ s.contains a := + ⟨toFinset_sub s a, sub_toFinset s a⟩ + +theorem not_mem_toFinset (s : HashSet α) (a : α) : a ∉ s.toFinset ↔ ¬s.contains a := by + simp [mem_toFinset] + +@[simp] +theorem toFinset_empty : toFinset (empty α) = ∅ := by + ext + simp [mem_toFinset, empty, contains, HashMap.not_contains_empty] + +theorem toFinset_of_isEmpty (s : HashSet α) : s.isEmpty → s.toFinset = ∅ := by + intro h + ext + simp [mem_toFinset, contains, HashMap.not_contains_of_isEmpty _ _ h] + +@[simp] +theorem toFinset_insert (s : HashSet α) (a : α) : + toFinset (s.insert a) = Insert.insert a s.toFinset := by + ext + simp [mem_toFinset, insert, contains, HashMap.contains_insert] + tauto + +@[simp] +theorem toFinset_singleton (a : α) : toFinset (singleton a) = {a} := by + simp [singleton, toFinset_insert] + +theorem toFinset_union_sub (s t : HashSet α) : (s.union t).toFinset ⊆ s.toFinset ∪ t.toFinset := by + dsimp [union] + intro x + apply HashMap.foldRecOn + (C := fun (acc : HashSet α) => x ∈ acc.toFinset → x ∈ s.toFinset ∪ t.toFinset) + (hInit := by simp; tauto) + intro _ a _ _ hFind + have : a ∈ t.toFinset := by + have := HashMap.contains_iff _ _|>.mpr ⟨_, hFind⟩ + simp [mem_toFinset, contains, this] + aesop + +theorem sub_toFinset_union_left (s t : HashSet α) : s.toFinset ⊆ (s.union t).toFinset := by + dsimp [union] + intro x + apply HashMap.foldRecOn + (C := fun (acc : HashSet α) => x ∈ s.toFinset → x ∈ acc.toFinset) + (hInit := id) + aesop + +theorem sub_toFinset_union (s t : HashSet α) : s.toFinset ∪ t.toFinset ⊆ (s.union t).toFinset := by + apply Finset.union_subset (sub_toFinset_union_left s t) + dsimp [union] + intro _ h + have ⟨_, hFind⟩ := HashMap.contains_iff _ _|>.mp (mem_toFinset _ _ |>.mp h) + have ⟨_, h⟩ := HashMap.fold_of_mapsTo_of_comm t (init := s) (fun acc a _ => acc.insert a) + hFind (by intros; apply HashMap.insert_comm) + simp [h] + +@[simp] +theorem toFinset_union (s t : HashSet α) : (s.union t).toFinset = s.toFinset ∪ t.toFinset := + subset_antisymm (toFinset_union_sub s t) (sub_toFinset_union s t) + +theorem toFinset_inter_sub (s t : HashSet α) : (s.inter t).toFinset ⊆ s.toFinset ∩ t.toFinset := by + dsimp [inter] + intro x + apply HashMap.foldRecOn + (C := fun (acc : HashSet α) => x ∈ acc.toFinset → x ∈ s.toFinset ∩ t.toFinset) + (hInit := by simp) + intro _ a _ _ hFind + have : a ∈ t.toFinset := by + have := HashMap.contains_iff _ _|>.mpr ⟨_, hFind⟩ + simp [mem_toFinset, contains, this] + split <;> + aesop (add norm mem_toFinset) + +theorem sub_toFinset_inter (s t : HashSet α) : s.toFinset ∩ t.toFinset ⊆ (s.inter t).toFinset := by + intro x + simp only [inter, Finset.mem_inter] + intro ⟨hS, hT⟩ + have ⟨_, hFind⟩ := HashMap.contains_iff _ _|>.mp (mem_toFinset _ _ |>.mp hT) + have ⟨_, h⟩ := HashMap.fold_of_mapsTo_of_comm t (init := empty α) + (fun acc a _ => if s.contains a then acc.insert a else acc) + hFind ?comm + case comm => + intros + dsimp [insert] + split_ifs <;> + aesop (add norm HashMap.insert_comm) + rw [h] + split + . simp + . have : x ∉ s.toFinset := + not_mem_toFinset _ _ |>.mpr (by assumption) + contradiction + +@[simp] +theorem toFinset_inter (s t : HashSet α) : (s.inter t).toFinset = s.toFinset ∩ t.toFinset := + subset_antisymm (toFinset_inter_sub s t) (sub_toFinset_inter s t) + +def Union (l : Array (HashSet α)) : HashSet α := + l.foldl (init := empty α) union + +theorem toFinset_Union (l : Array (HashSet α)) : + toFinset (Union l) = l.foldl (init := ∅) fun acc s => acc ∪ s.toFinset := by + have : ∀ t, toFinset (l.foldl (init := t) union) = + l.foldl (init := t.toFinset) fun acc s => acc ∪ s.toFinset := by + simp only [Array.foldl_eq_foldl_data] + induction l.data <;> simp_all + simp [Union, this] + +/-- Calculate the union of an array of `HashSet`s, and check if the array elements are all pairwise +disjoint. Return `(⋃ ss, true)` if array elements are pairwise disjoint, otherwise `(⋃ ss, false)`. +-/ +def disjointUnion (ss : Array (HashSet α)) : HashSet α × Bool := + ss.foldl (init := (.empty α, true)) fun (U, b) t => + (U.union t, b && (U.inter t).isEmpty) + +theorem disjointUnion_characterization (ss : Array (HashSet α)) : + (∀ a, a ∈ (disjointUnion ss).fst.toFinset ↔ ∃ s ∈ ss.data, a ∈ s.toFinset) + ∧ ((disjointUnion ss).snd → + ∀ (i j : Fin ss.size), i ≠ j → ss[i].toFinset ∩ ss[j].toFinset = ∅) := + have ⟨h₁, h₂, h₃⟩ := ss.foldl_induction + (motive := fun i (acc : HashSet α × Bool) => + (∀ a ∈ acc.1.toFinset, ∃ s ∈ ss.data, a ∈ s.toFinset) ∧ + (∀ (j : Fin ss.size), j < i → ss[j].toFinset ⊆ acc.1.toFinset) ∧ + (acc.2 → ∀ (j k : Fin ss.size), j < i → k < i → j ≠ k → ss[j].toFinset ∩ ss[k].toFinset = ∅)) + (init := (empty α, true)) (h0 := by simp) + (f := fun acc t => + (acc.1.union t, acc.2 && (acc.1.inter t).isEmpty)) + (hf := by + intro i (U, b) ⟨ih₁, ih₂, ih₃⟩ + simp only [toFinset_union, Finset.mem_union] + refine ⟨?step₁, ?step₂, ?step₃⟩ + case step₁ => + intro a hMem + cases hMem with + | inl h => + exact ih₁ a h + | inr h => + exact ⟨ss[i], Array.get_mem_data ss i, h⟩ + case step₂ => + intro j hJ + cases Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hJ) with + | inl h => + have := ih₂ j h + exact subset_trans this (Finset.subset_union_left _ _) + | inr h => + simp [h, Finset.subset_union_right] + case step₃ => + intro hB j k hJ hK hNe + simp only [Bool.and_eq_true] at hB + cases Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hJ) <;> + cases Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hK) + case inl.inl hJ hK => + exact ih₃ hB.left j k hJ hK hNe + case inr.inr hJ hK => + have := hJ.trans hK.symm + exact absurd (Fin.eq_of_val_eq this) hNe + case inl.inr hJ hK => + have hB := toFinset_of_isEmpty _ hB.right + simp only [toFinset_inter] at hB + apply Finset.subset_empty.mp + have := ih₂ j hJ + have := Finset.inter_subset_inter_right this (u := ss[k].toFinset) + simp_all + case inr.inl hJ hK => + have hB := toFinset_of_isEmpty _ hB.right + rw [toFinset_inter, Finset.inter_comm] at hB + apply Finset.subset_empty.mp + have := ih₂ k hK + have := Finset.inter_subset_inter_left this (s := ss[j].toFinset) + simp_all) + by + dsimp [disjointUnion] + refine ⟨fun a => ⟨fun hMem => h₁ a hMem, ?_⟩, + fun h i j hNe => h₃ h i j i.isLt j.isLt hNe⟩ + intro ⟨s, hS, hA⟩ + have ⟨i, hI⟩ := Array.get_of_mem_data hS + exact h₂ i i.isLt (hI ▸ hA) + +theorem mem_disjointUnion (ss : Array (HashSet α)) (a : α) : + a ∈ (disjointUnion ss).fst.toFinset ↔ ∃ s ∈ ss.data, a ∈ s.toFinset := + disjointUnion_characterization ss |>.left a + +theorem disjoint_disjointUnion (ss : Array (HashSet α)) : (disjointUnion ss).snd → + ∀ (i j : Nat) (hI : i < ss.size) (hJ : j < ss.size), i ≠ j → + ss[i].toFinset ∩ ss[j].toFinset = ∅ := + fun h i j hI hJ hNe => + disjointUnion_characterization ss |>.right h ⟨i, hI⟩ ⟨j, hJ⟩ (by simp [hNe]) + +end HashSet diff --git a/Experiments/CPOG/Data/ICnf.lean b/Experiments/CPOG/Data/ICnf.lean new file mode 100644 index 0000000..0e1817d --- /dev/null +++ b/Experiments/CPOG/Data/ICnf.lean @@ -0,0 +1,698 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import Mathlib.Tactic.Linarith + +import ProofChecker.Data.HashMap.Lemmas +import ProofChecker.Data.HashSet +import ProofChecker.Model.ToMathlib +import ProofChecker.Model.PropTerm +import ProofChecker.Model.PropVars + +abbrev Var := PNat + +namespace Var + +instance : ToString Var where + toString x := toString x.val + +instance : Hashable Var where + hash v := hash v.val + +instance : Ord Var where + compare a b := compare a.val b.val + +end Var + +/-! Literals -/ + +def ILit := { i : Int // i ≠ 0 } + deriving DecidableEq, Repr + +namespace ILit + +def mkPos (x : Var) : ILit := + ⟨Int.ofNat x.val, by simp⟩ + +def mkNeg (x : Var) : ILit := + ⟨-Int.ofNat x.val, by simp⟩ + +def mk (x : Var) (p : Bool) : ILit := + if p then mkPos x else mkNeg x + +instance : Coe Var ILit := + ⟨mkPos⟩ + +def var (l : ILit) : Var := + ⟨Int.natAbs l.val, Int.natAbs_pos.mpr l.property⟩ + +def polarity (l : ILit) : Bool := + (0 : Int) < l.val + +def negate (l : ILit) : ILit := + ⟨-l.val, Int.neg_ne_zero.mpr l.property⟩ + +instance : Neg ILit := ⟨negate⟩ + +instance : ToString ILit where + toString l := if l.polarity then s!"{l.var}" else s!"-{l.var}" + +/-! Theorems about `ILit` -/ + +@[simp] +theorem var_mkPos (x : Var) : var (mkPos x) = x := + Subtype.ext (Int.natAbs_ofNat x.val) + +@[simp] +theorem var_mkNeg (x : Var) : var (mkNeg x) = x := by + apply Subtype.ext + simp [var, mkNeg] + rfl + +@[simp] +theorem var_mk (x : Var) (p : Bool) : var (mk x p) = x := by + dsimp [mk]; split <;> simp + +@[simp] +theorem polarity_mkPos (x : Var) : polarity (mkPos x) = true := by + simp [polarity, mkPos] + +@[simp] +theorem polarity_mkNeg (x : Var) : polarity (mkNeg x) = false := by + simp [polarity, mkNeg] + +@[simp] +theorem polarity_mk (x : Var) (p : Bool) : polarity (mk x p) = p := by + dsimp [mk]; split <;> simp_all + +@[simp] +theorem var_negate (l : ILit) : (-l).var = l.var := by + simp only [var, Neg.neg, negate] + apply Subtype.ext + apply Int.natAbs_neg + +theorem polarity_eq {l₁ l₂ : ILit} : + l₁.polarity = l₂.polarity ↔ ((0 : Int) < l₁.val ↔ (0 : Int) < l₂.val) := by + simp [polarity] + +@[simp] +theorem polarity_negate (l : ILit) : (-l).polarity = !l.polarity := by + rw [Bool.eq_bnot_to_not_eq, polarity_eq] + intro hEq + exact l.property (Int.eq_zero_of_lt_neg_iff_lt _ hEq) + +@[ext] +theorem ext {l₁ l₂ : ILit} : l₁.var = l₂.var → l₁.polarity = l₂.polarity → l₁ = l₂ := by + /- Strip type alias. -/ + suffices ∀ {l₁ l₂ : Int}, l₁.natAbs = l₂.natAbs → (0 < l₁ ↔ 0 < l₂) → l₁ = l₂ by + intro h₁ h₂ + apply Subtype.ext + apply this + . exact Subtype.mk_eq_mk.mp h₁ + . exact polarity_eq.mp h₂ + intro l₁ l₂ h₁ h₂ + cases Int.natAbs_eq_natAbs_iff.mp h₁ + . assumption + next h => + rw [h] at h₂ + have : l₂ = 0 := Int.eq_zero_of_lt_neg_iff_lt l₂ h₂ + simp [this, h] + +@[simp] +theorem eta (l : ILit) : mk l.var l.polarity = l := by + apply ext <;> simp + +@[simp] +theorem eta_neg (l : ILit) : mk l.var (!l.polarity) = -l := by + apply ext <;> simp + +theorem mkPos_or_mkNeg (l : ILit) : l = .mkPos l.var ∨ l = .mkNeg l.var := by + rw [← eta l] + cases l.polarity + . apply Or.inr + simp [mk] + . apply Or.inl + simp [mk] + +def toPropForm (l : ILit) : PropForm Var := + if l.polarity then .var l.var else .neg (.var l.var) + +@[simp] +theorem toPropForm_mkPos (x : Var) : (mkPos x).toPropForm = .var x := by + simp [toPropForm] + +@[simp] +theorem toPropForm_mkNeg (x : Var) : (mkNeg x).toPropForm = .neg (.var x) := by + simp [toPropForm] + +def toPropTerm (l : ILit) : PropTerm Var := + if l.polarity then .var l.var else (.var l.var)ᶜ + +@[simp] +theorem mk_toPropForm (l : ILit) : ⟦l.toPropForm⟧ = l.toPropTerm := by + dsimp [toPropForm, toPropTerm] + cases l.polarity <;> simp + +@[simp] +theorem vars_toPropForm (l : ILit) : l.toPropForm.vars = {l.var} := by + dsimp [toPropForm] + cases l.polarity <;> simp [PropForm.vars] + +@[simp] +theorem toPropTerm_mkPos (x : Var) : (mkPos x).toPropTerm = .var x := by + simp [toPropTerm] + +@[simp] +theorem toPropTerm_mkNeg (x : Var) : (mkNeg x).toPropTerm = (.var x)ᶜ := by + simp [toPropTerm] + +@[simp] +theorem toPropTerm_neg (l : ILit) : (-l).toPropTerm = l.toPropTermᶜ := by + dsimp [toPropTerm] + aesop + +@[simp] +theorem semVars_toPropTerm (l : ILit) : l.toPropTerm.semVars = {l.var} := by + dsimp [toPropTerm] + cases l.polarity <;> simp + +open PropTerm + +theorem satisfies_iff {τ : PropAssignment Var} {l : ILit} : + τ ⊨ l.toPropTerm ↔ τ l.var = l.polarity := by + dsimp [toPropTerm, var, polarity] + aesop + +theorem satisfies_neg {τ : PropAssignment Var} {l : ILit} : + τ ⊨ (-l).toPropTerm ↔ τ ⊭ l.toPropTerm := by + simp [satisfies_iff] + +theorem satisfies_set [DecidableEq ν] (τ : PropAssignment Var) (l : ILit) : + τ.set l.var l.polarity ⊨ l.toPropTerm := by + simp [satisfies_iff, τ.set_get] + +theorem eq_of_flip {τ : PropAssignment Var} {l : ILit} {x : Var} {p : Bool} : + τ ⊭ l.toPropTerm → τ.set x p ⊨ l.toPropTerm → l = mk x p := by + simp only [satisfies_iff] + intro h hSet + by_cases hEq : x = var l + . rw [hEq, τ.set_get] at hSet + simp [hSet, hEq] + . exfalso; exact h (τ.set_get_of_ne p hEq ▸ hSet) + +theorem eq_of_flip' {τ : PropAssignment Var} {l : ILit} {x : Var} {p : Bool} : + τ ⊨ l.toPropTerm → τ.set x p ⊭ l.toPropTerm → l = mk x !p := by + simp only [satisfies_iff] + intro h hSet + by_cases hEq : x = var l + . rw [hEq, τ.set_get] at hSet + have : (!p) = l.polarity := by + simp [hSet] + simp [hEq, this] + . exfalso; exact hSet (τ.set_get_of_ne p hEq ▸ h) + +end ILit + +/-! Clauses -/ + +abbrev IClause := Array ILit + +namespace IClause + +def vars (C : IClause) : HashSet Var := + C.foldr (init := .empty Var) fun l acc => acc.insert l.var + +instance : BEq IClause := + inferInstanceAs (BEq IClause) + +instance : ToString IClause where + toString C := s!"({String.intercalate " ∨ " (C.map toString).toList})" + +/-! Theorems about `IClause` -/ + +theorem mem_vars (C : IClause) (x : Var) : x ∈ C.vars.toFinset ↔ ∃ l ∈ C.data, x = l.var := by + rw [vars, Array.foldr_eq_foldr_data] + induction C.data <;> aesop + +def toPropForm (C : IClause) : PropForm Var := + C.data.foldr (init := .fls) (fun l φ => l.toPropForm.disj φ) + +def toPropTerm (C : IClause) : PropTerm Var := + C.data.foldr (init := ⊥) (fun l φ => l.toPropTerm ⊔ φ) + +@[simp] +theorem mk_toPropForm (C : IClause) : ⟦C.toPropForm⟧ = C.toPropTerm := by + dsimp [toPropForm, toPropTerm] + induction C.data <;> simp_all + +@[simp] +theorem vars_toPropForm (C : IClause) : C.toPropForm.vars = C.vars.toFinset := by + ext x + simp [mem_vars, toPropForm] + induction C.data <;> simp_all [PropForm.vars] + +open PropTerm + +theorem satisfies_iff {τ : PropAssignment Var} {C : IClause} : + τ ⊨ C.toPropTerm ↔ ∃ l ∈ C.data, τ ⊨ l.toPropTerm := by + rw [toPropTerm] + induction C.data <;> simp_all + +theorem semVars_sub (C : IClause) : C.toPropTerm.semVars ⊆ C.vars.toFinset := by + rw [← vars_toPropForm, ← mk_toPropForm] + apply PropForm.semVars_subset_vars + +theorem tautology_iff (C : IClause) : + C.toPropTerm = ⊤ ↔ ∃ l₁ ∈ C.data, ∃ l₂ ∈ C.data, l₁ = -l₂ := by + refine ⟨?mp, ?mpr⟩ + case mp => + refine not_imp_not.mp ?_ + simp only [not_exists, not_and] + unfold toPropTerm -- :( have to do it because no induction principle for arrays + induction C.data with + | nil => simp + | cons l₀ ls ih => + -- crazy list-array induction boilerplate + have : ls.foldr (init := ⊥) (fun l φ => l.toPropTerm ⊔ φ) = toPropTerm ls.toArray := by + simp [toPropTerm] + simp only [List.foldr_cons, this] at * + -- end boilerplate + intro hCompl hEq + specialize ih fun l₁ h₁ l₂ h₂ => hCompl l₁ (by simp [h₁]) l₂ (by simp [h₂]) + simp only [PropTerm.eq_top_iff, satisfies_disj, not_forall] at hEq ih + have ⟨τ₀, h₀⟩ := ih + have := hEq τ₀ + have : τ₀ ⊨ l₀.toPropTerm := by tauto + let τ₁ := τ₀.set l₀.var !l₀.polarity + have : τ₁ ⊭ l₀.toPropTerm := by simp [ILit.satisfies_iff] + have : τ₁ ⊭ toPropTerm ls.toArray := fun h => by + have ⟨lₛ, hₛ, hτ⟩ := satisfies_iff.mp h + simp only [satisfies_iff, not_exists, not_and] at h₀ + have : τ₀ ⊭ lₛ.toPropTerm := h₀ lₛ hₛ + have : lₛ = ILit.mk l₀.var !l₀.polarity := ILit.eq_of_flip this hτ + have : lₛ = -l₀ := by simp [this] + simp at hₛ + apply hCompl lₛ (List.mem_cons_of_mem _ hₛ) l₀ (List.mem_cons_self _ _) this + have := hEq τ₁ + tauto + case mpr => + intro ⟨l₁, h₁, l₂, h₂, hEq⟩ + ext τ + rw [satisfies_iff] + by_cases hτ : τ ⊨ l₂.toPropTerm + . aesop + . have : τ ⊨ l₁.toPropTerm := by + rw [hEq, ILit.satisfies_neg] + assumption + tauto + +/-! Tautology decision procedure -/ + +/-- `encodes enc C` says that the hashmap `enc` encodes the (non-tautological) clause `C`. +More generally, `encodes enc C i` says that `enc` encodes the disjunction of all but the +first `i` literals of `C`. -/ +def encodes (enc : HashMap Var Bool) (C : IClause) (start : Nat := 0) : Prop := + (∀ j : Fin C.size, start ≤ j → enc.find? C[j].var = .some C[j].polarity) ∧ + ∀ x : Var, enc.contains x ↔ ∃ j : Fin C.size, start ≤ j ∧ C[j].var = x + +theorem encodes_empty (C : IClause) : encodes HashMap.empty C (Array.size C) := by + simp [encodes]; intro j; exact not_le_of_lt j.isLt + +theorem not_tautology_of_encodes (C : IClause) (enc : HashMap Var Bool) (h : encodes enc C) : + ¬ (toPropTerm C = ⊤) := by + rw [tautology_iff]; simp only [not_exists, not_and] + intros l₁ hl₁ l₂ hl₂ heq + have ⟨i, hi⟩ := C.get_of_mem_data hl₁ + have ⟨j, hj⟩ := C.get_of_mem_data hl₂ + simp only [encodes, zero_le, forall_true_left, true_and] at h + have hi' := h.1 i + rw [hi, heq, ILit.var_negate, ILit.polarity_negate] at hi' + have hj' := h.1 j + rw [hj, hi'] at hj' + simp at hj' + +theorem encodes_insert_of_find?_eq_none {C : IClause} {i : Nat} {enc : HashMap Var Bool} + (ilt: i < C.size) + (henc : encodes enc C (i + 1)) + (h: HashMap.find? enc C[i].var = none) : + encodes (HashMap.insert enc C[i].var C[i].polarity) C i := by + constructor + . intro j hile + cases lt_or_eq_of_le hile + case inl h' => + have := henc.1 _ (Nat.succ_le_of_lt h') + rw [HashMap.find?_insert_of_ne, this] + rw [bne_iff_ne, ne_eq] + intro hc + rw [←hc, h] at this; contradiction + case inr h' => + cases h' + simp [HashMap.find?_insert] + . intro x + rw [HashMap.contains_insert, henc.2 x, beq_iff_eq]; simp only [getElem_fin] + constructor + . rintro (⟨j, hile, rfl⟩ | rfl) + . use j, (Nat.le_succ i).trans hile + . use ⟨i, ilt⟩; simp + . rintro ⟨j, hile, rfl⟩ + cases lt_or_eq_of_le hile + case inl h' => + left; use j, Nat.succ_le_of_lt h' + case inr h' => + right; simp [h'] + +theorem tautology_of_encodes_of_find?_eq_some + {C : IClause} {i : Nat} {enc : HashMap Var Bool} {p : Bool} + (ilt: i < C.size) + (henc : encodes enc C (i + 1)) + (h : HashMap.find? enc C[i].var = some p) + (hpne : p ≠ C[i].polarity) : + toPropTerm C = ⊤ := by + rw [tautology_iff] + use C[i], C.get_mem_data ⟨i, ilt⟩ + have : enc.contains C[i].var := by + rw [HashMap.contains_iff]; use p; exact h + rw [henc.2] at this + rcases this with ⟨j, hj, h'⟩ + use C[j], C.get_mem_data j + ext; rw [ILit.var_negate, h'] + have := henc.1 j hj + rw [h', h, Option.some.injEq] at this + rw [ILit.polarity_negate, Bool.eq_bnot_to_not_eq, ←this] + exact hpne.symm + +theorem encode_of_encodes_of_find?_eq_some + {C : IClause} {i : Nat} {enc : HashMap Var Bool} {p : Bool} + (ilt: i < C.size) + (henc : encodes enc C (i + 1)) + (h : HashMap.find? enc C[i].var = some p) + (hpeq : p = C[i].polarity) : + encodes enc C i := by + constructor + . intro j hile + cases lt_or_eq_of_le hile + case inl h' => + exact henc.1 _ (Nat.succ_le_of_lt h') + case inr h' => cases h'; simp [h, hpeq] + . intro x + rw [henc.2] + constructor + . rintro ⟨j, hile, rfl⟩ + use j, (Nat.le_succ i).trans hile + . rintro ⟨j, hile, rfl⟩ + cases lt_or_eq_of_le hile + case inl h' => use j, Nat.succ_le_of_lt h' + case inr h' => + have : enc.contains C[i].var := by + rw [HashMap.contains_iff]; use p; exact h + rw [henc.2] at this + rcases this with ⟨j', hj', h''⟩ + use j', hj' + rw [h'']; cases h'; simp + +def checkTautoAux (C : IClause) : { b : Bool // b ↔ toPropTerm C = ⊤ } := + go C.size (le_refl _) .empty C.encodes_empty +where + go : (i : Nat) → i ≤ C.size → (acc : HashMap Var Bool) → encodes acc C i → + { b : Bool // b ↔ toPropTerm C = ⊤ } + | 0, _, acc, hinv => ⟨false, by simp [C.not_tautology_of_encodes acc hinv]⟩ + | i+1, hi, acc, hinv => + have ilt := Nat.lt_of_succ_le hi + match h: acc.find? C[i].var with + | .none => go i (le_of_lt ilt) _ (encodes_insert_of_find?_eq_none ilt hinv h) + | .some p => + if hp: p = C[i].polarity then + go i (le_of_lt ilt) _ (encode_of_encodes_of_find?_eq_some ilt hinv h hp) + else + ⟨true, by simp [tautology_of_encodes_of_find?_eq_some ilt hinv h hp]⟩ + +instance : DecidablePred (IClause.toPropTerm · = ⊤) := + fun C => match checkTautoAux C with + | ⟨true, h⟩ => .isTrue (h.mp rfl) + | ⟨false, h⟩ => .isFalse fun hC => nomatch h.mpr hC + +/-- Check whether a clause is a tautology. The type is a hack for early-return. The clause is +tautological iff `none` is returned. -/ +@[deprecated checkTautoAux] +def checkTautoAux' (C : IClause) : Option (HashMap Var Bool) := + C.foldlM (init := .empty) fun acc l => do + match acc.find? l.var with + | .none => acc.insert l.var l.polarity + | .some p => if p ≠ l.polarity then none else acc + +end IClause + +/-! CNF -/ + +abbrev ICnf := Array IClause + +namespace ICnf + +def vars (φ : ICnf) : HashSet Var := + φ.foldr (init := .empty Var) fun C acc => acc.union C.vars + +instance : ToString ICnf where + toString C := s!"{String.intercalate " ∧ " (C.map toString).toList}" + +/-! Theorems about `ICnf` -/ + +theorem mem_vars (φ : ICnf) (x : Var) : x ∈ φ.vars.toFinset ↔ ∃ C ∈ φ.data, x ∈ C.vars.toFinset := +by + simp only [vars, Array.foldr_eq_foldr_data] + induction φ.data <;> aesop + +def toPropForm (φ : ICnf) : PropForm Var := + φ.data.foldr (init := .tr) (fun l φ => l.toPropForm.conj φ) + +def toPropTerm (φ : ICnf) : PropTerm Var := + φ.data.foldr (init := ⊤) (fun l φ => l.toPropTerm ⊓ φ) + +@[simp] +theorem mk_toPropForm (φ : ICnf) : ⟦φ.toPropForm⟧ = φ.toPropTerm := by + simp only [toPropForm, toPropTerm] + induction φ.data <;> simp_all + +@[simp] +theorem vars_toPropForm (φ : ICnf) : φ.toPropForm.vars = φ.vars.toFinset := by + ext x + simp only [mem_vars, toPropForm] + induction φ.data <;> simp_all [PropForm.vars] + +open PropTerm + +theorem satisfies_iff {τ : PropAssignment Var} {φ : ICnf} : + τ ⊨ φ.toPropTerm ↔ ∀ C ∈ φ.data, τ ⊨ C.toPropTerm := by + rw [toPropTerm] + induction φ.data <;> simp_all + +theorem semVars_sub (φ : ICnf) : φ.toPropTerm.semVars ⊆ φ.vars.toFinset := by + rw [← vars_toPropForm, ← mk_toPropForm] + apply PropForm.semVars_subset_vars + +end ICnf + +/-! Partial assignments -/ + +/-- A partial assignment to propositional variables. -/ +-- TODO: Using `HashMap` for this is cache-inefficient but I don't have time to verify better +-- structures rn +abbrev PartPropAssignment := HashMap Var Bool + +namespace PartPropAssignment + +/-- Interpret the assignment (x ↦ ⊤, y ↦ ⊥) as x ∧ ¬y, for example. -/ +-- NOTE: Partial assignments really are more like formulas than they are like assignments because +-- there is no nice to way to extend one to a `PropAssignment` (i.e. a total assignment). +def toPropTerm (τ : PartPropAssignment) : PropTerm Var := + τ.fold (init := ⊤) fun acc x v => acc ⊓ if v then .var x else (.var x)ᶜ + +instance : ToString PartPropAssignment where + toString τ := String.intercalate " ∧ " + (τ.fold (init := []) (f := fun acc x p => s!"{ILit.mk x p}" :: acc)) + +open PropTerm + +theorem satisfies_iff (τ : PartPropAssignment) (σ : PropAssignment Var) : + σ ⊨ τ.toPropTerm ↔ ∀ x p, τ.find? x = some p → σ x = p := + ⟨mp, mpr⟩ +where + mp := fun h => by + intro x p? hFind + have ⟨φ, hφ⟩ := τ.fold_of_mapsTo_of_comm + (init := ⊤) (f := fun acc x v => acc ⊓ if v then PropTerm.var x else (PropTerm.var x)ᶜ) + hFind ?comm + case comm => + intros + dsimp + ac_rfl + rw [toPropTerm, hφ] at h + aesop + + mpr := fun h => by + apply HashMap.foldRecOn (hInit := satisfies_tr) + intro φ x p hφ hFind + rw [satisfies_conj] + refine ⟨hφ, ?_⟩ + have := h _ _ hFind + split <;> simp [*] + +end PartPropAssignment + +namespace IClause + +/-- Reduces a clause by a partial assignment. Returns `none` if it became satisfied, +otherwise `some C'` where `C'` is the reduced clause. -/ +def reduce (C : IClause) (τ : PartPropAssignment) : Option IClause := + C.foldlM (init := #[]) fun acc l => + match τ.find? l.var with + | some v => if v = l.polarity then none else acc + | none => some <| acc.push l + +theorem reduce_characterization (C : IClause) (σ : PartPropAssignment) : + SatisfiesM (fun C' => + ∀ l ∈ C.data, (!σ.contains l.var → l ∈ C'.data) ∧ + σ.find? l.var ≠ some l.polarity) (reduce C σ) := by + have := C.SatisfiesM_foldlM (init := #[]) (f := fun acc l => + match σ.find? l.var with + | some v => if v = l.polarity then none else acc + | none => some <| acc.push l) + (motive := fun sz acc => + ∀ (i : Fin C.size), i < sz → (!σ.contains C[i].var → C[i] ∈ acc.data) ∧ + σ.find? C[i].var ≠ some C[i].polarity) + (h0 := by simp) + (hf := by + simp only [SatisfiesM_Option_eq, getElem_fin] + intro sz acc ih acc' + split; split + . simp + next p hFind hP => + intro h i hLt; injection h with h; rw [← h] + refine Or.elim (Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hLt)) (ih i) fun hEq => ?_ + simp only [hEq] + refine ⟨?l, fun h => ?r⟩ + case r => + rw [hFind] at h + injection h with h + exact hP h + case l => + have := HashMap.contains_iff _ _ |>.mpr ⟨_, hFind⟩ + simp_all + next p hFind => + intro h i hLt; injection h with h; rw [← h] + simp only [Array.push_data, List.mem_append, List.mem_singleton] + refine Or.elim (Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hLt)) (fun hLt => ?_) fun hEq => ?_ + <;> aesop + ) + dsimp [reduce] + apply SatisfiesM.imp this + intro C' hRed + exact fun l hL => + have ⟨i, h⟩ := Array.get_of_mem_data hL + h ▸ hRed i i.isLt + +open PropTerm in +theorem reduce_eq_some (C C' : IClause) (σ : PartPropAssignment) : + reduce C σ = some C' → C.toPropTerm ⊓ σ.toPropTerm ≤ C'.toPropTerm := by + intro hSome + have hRed := SatisfiesM_Option_eq.mp (reduce_characterization C σ) _ hSome + refine entails_ext.mpr fun τ hτ => ?_ + rw [satisfies_conj] at hτ + have ⟨l, hL, hτL⟩ := IClause.satisfies_iff.mp hτ.left + by_cases hCont : σ.contains l.var + next => + exfalso + have ⟨p, hFind⟩ := HashMap.contains_iff _ _ |>.mp hCont + have := PartPropAssignment.satisfies_iff _ _ |>.mp hτ.right _ _ hFind + have : p = l.polarity := by + rw [ILit.satisfies_iff, this] at hτL + assumption + exact hRed l hL |>.right (this ▸ hFind) + next => + simp only [Bool.not_eq_true, Bool.bnot_eq_to_not_eq] at * + exact IClause.satisfies_iff.mpr ⟨l, (hRed l hL).left hCont, hτL⟩ + +/-- When `C` is not a tautology, return the smallest assignment falsifying it. When it is not, +return an undetermined assignment. -/ +def toFalsifyingAssignment (C : IClause) : PartPropAssignment := + C.foldl (init := .empty) fun acc l => acc.insert l.var !l.polarity + +theorem toFalsifyingAssignment_characterization (C : IClause) : C.toPropTerm ≠ ⊤ → + (∀ i : Fin C.size, C.toFalsifyingAssignment.find? C[i].var = some !C[i].polarity) ∧ + (∀ x p, C.toFalsifyingAssignment.find? x = some p → (ILit.mk x !p) ∈ C.data) := by + intro hTauto + have := C.foldl_induction + (motive := fun (sz : Nat) (τ : PartPropAssignment) => + (∀ i : Fin C.size, i < sz → τ.find? C[i].var = some !C[i].polarity) ∧ + (∀ x p, τ.find? x = some p → (ILit.mk x !p) ∈ C.data)) + (init := .empty) + (f := fun acc l => acc.insert l.var !l.polarity) + (h0 := by simp) + (hf := by + intro sz τ ⟨ih₁, ih₂⟩ + refine ⟨?step₁, ?step₂⟩ + case step₁ => + intro i hLt + cases Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hLt) with + | inl h => + by_cases hEq : C[sz].var = C[i].var + . have : C[sz].polarity = C[i].polarity := by + by_contra hPol + have : C[sz] = -C[i] := by + apply ILit.ext <;> simp_all + apply hTauto + rw [tautology_iff] + exact ⟨C[sz], Array.get_mem_data _ _, C[i], Array.get_mem_data _ _, this⟩ + have : C[sz] = C[i] := ILit.ext hEq this + simp_all [HashMap.find?_insert] + . simp only [HashMap.find?_insert_of_ne _ _ (bne_iff_ne _ _ |>.mpr hEq), ih₁ i h] + | inr h => + simp [h] + rw [HashMap.find?_insert _ _ LawfulBEq.rfl] + case step₂ => + intro x p hFind + by_cases hEq : C[sz].var = x + . rw [← hEq, HashMap.find?_insert _ _ (LawfulBEq.rfl)] at hFind + injection hFind with hFind + rw [← hEq, ← hFind] + simp [Array.getElem_mem_data] + . rw [HashMap.find?_insert_of_ne _ _ (bne_iff_ne _ _|>.mpr hEq)] at hFind + apply ih₂ _ _ hFind) + dsimp [toFalsifyingAssignment] + exact ⟨fun i => this.left i i.isLt, this.right⟩ + +theorem toFalsifyingAssignment_ext (C : IClause) : C.toPropTerm ≠ ⊤ → + (∀ l, l ∈ C.data ↔ (toFalsifyingAssignment C).find? l.var = some !l.polarity) := by + intro hTauto l + have ⟨h₁, h₂⟩ := toFalsifyingAssignment_characterization C hTauto + apply Iff.intro + . intro hL + have ⟨i, hI⟩ := Array.get_of_mem_data hL + rw [← hI] + exact h₁ i + . intro hFind + have := h₂ _ _ hFind + rw [Bool.not_not, ILit.eta] at this + exact this + +theorem toPropTerm_toFalsifyingAssignment (C : IClause) : C.toPropTerm ≠ ⊤ → + C.toFalsifyingAssignment.toPropTerm = C.toPropTermᶜ := by + intro hTauto + have := toFalsifyingAssignment_ext C hTauto + ext τ + simp only [PartPropAssignment.satisfies_iff, PropTerm.satisfies_neg, IClause.satisfies_iff, + not_exists, not_and, ILit.satisfies_iff] + apply Iff.intro + . intro h l hL hτ + have := h _ _ (this l |>.mp hL) + simp [hτ] at this + . intro h x p hFind + have := this (ILit.mk x !p) + simp only [ILit.var_mk, ILit.polarity_mk, Bool.not_not] at this + have := h _ (this.mpr hFind) + simp at this + exact this + +end IClause \ No newline at end of file diff --git a/Experiments/CPOG/Data/Pog.lean b/Experiments/CPOG/Data/Pog.lean new file mode 100644 index 0000000..c724f11 --- /dev/null +++ b/Experiments/CPOG/Data/Pog.lean @@ -0,0 +1,648 @@ +/- +Copyright (c) 2023 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad, Wojciech Nawrocki +-/ + +import Mathlib.Data.Finset.Card +import Mathlib.Data.Finset.Powerset +import Mathlib.Data.PNat.Basic +import Mathlib.Algebra.BigOperators.Basic +import ProofChecker.Data.ICnf +import ProofChecker.Model.PropVars + +open Nat +abbrev Cube := Array ILit + +namespace ILit + +theorem mkPos_var_true (l : ILit) (h : l.polarity = true) : + mkPos (var l) = l := by + conv => rhs; rw [←eta l]; simp [h, mk] + +theorem mkPos_var_false (l : ILit) (h : l.polarity = false) : + mkPos (var l) = -l := by + conv => rhs; rw [←eta_neg l]; simp [h, mk] + +end ILit + +namespace PropForm + +def partitioned [DecidableEq ν]: PropForm ν → Prop + | tr => True + | fls => True + | var _ => True + | neg φ => φ.partitioned + | disj φ ψ => φ.partitioned ∧ ψ.partitioned ∧ ∀ v, ¬ (φ.eval v ∧ ψ.eval v) + | conj φ ψ => φ.partitioned ∧ ψ.partitioned ∧ (φ.vars ∩ ψ.vars = ∅) + | impl _ _ => False + | biImpl _ _ => False + +def listConj (φs : List (PropForm Var)) : PropForm Var := + φs.foldr (init := .tr) (f := .conj) + +def listConjTerm' (φs : List (PropForm Var)) : PropTerm Var := + φs.foldr (init := ⊤) (f := (⟦·⟧ ⊓ ·)) -- fold using the monocle capybara operator + +def listConjTerm (φs : List (PropTerm Var)) : PropTerm Var := + φs.foldr (init := ⊤) (f := (· ⊓ ·)) + +open PropTerm in +theorem satisfies_listConjTerm (φs : List (PropTerm Var)) (τ : PropAssignment Var) : + τ ⊨ listConjTerm φs ↔ ∀ φ ∈ φs, τ ⊨ φ := by + dsimp [listConjTerm] + induction φs <;> simp_all + +@[simp] +theorem listConjTerm_nil : listConjTerm [] = ⊤ := rfl + +lemma mem_vars_foldr_conj (φs : List (PropForm Var)) (x : Var) : + x ∈ (φs.foldr (init := PropForm.tr) (f := .conj)).vars ↔ + ∃ i : Fin (φs.length), x ∈ (φs.get i).vars := by + induction φs + . simp [PropForm.vars] + . next φ φs ih => + simp [PropForm.vars, ih, Fin.exists_fin_succ] + +theorem partitioned_listConj (φs : List (PropForm Var)) : + (listConj φs).partitioned ↔ + ∀ i : Fin φs.length, (φs.get i).partitioned ∧ + ∀ j : Fin φs.length, i ≠ j → (φs.get i).vars ∩ (φs.get j).vars = ∅ := by + induction φs + . dsimp [listConj, partitioned]; simp + . next φ φs ih => + dsimp [listConj, partitioned] at * + simp only [ih, Finset.inter_self, List.get, not_true, IsEmpty.forall_iff, true_and, + add_eq, add_zero, Fin.eta, mem_vars_foldr_conj, Fin.forall_fin_succ] + have aux : vars φ ∩ vars (List.foldr conj tr φs) = ∅ ↔ + ∀ i : Fin (List.length φs), vars φ ∩ vars (List.get φs i) = ∅ := by + simp only [Finset.eq_empty_iff_forall_not_mem, Finset.mem_inter, not_and, mem_vars_foldr_conj, + not_exists] + aesop + have aux2 : ∀ i : Fin (List.length φs), + vars (List.get φs i) ∩ vars φ = vars φ ∩ vars (List.get φs i) := by + intro i; rw [Finset.inter_comm] + have aux3 : ∀ i : Fin (List.length φs), ¬ 0 = Fin.succ i := by + intro i; apply Ne.symm; apply Fin.succ_ne_zero + aesop + +def arrayConj (φs : Array (PropForm Var)) : PropForm Var := listConj φs.data + +theorem mem_vars_arrayConj (φs : Array (PropForm Var)) (x : Var) : + x ∈ (arrayConj φs).vars ↔ ∃ i : Fin φs.size, x ∈ φs[i].vars := + mem_vars_foldr_conj φs.data x + +theorem partitioned_arrayConj (φs : Array (PropForm Var)) : + (arrayConj φs).partitioned ↔ + ∀ i : Fin φs.size, φs[i].partitioned ∧ + ∀ j : Fin φs.size, i ≠ j → φs[i].vars ∩ φs[j].vars = ∅ := by + dsimp [arrayConj]; rw [partitioned_listConj]; rfl + +def arrayConjTerm (φs : Array (PropForm Var)) : PropTerm Var := + φs.data.foldr (init := ⊤) (f := fun φ acc => ⟦φ⟧ ⊓ acc) + +theorem arrayConjTerm_eq_listConjTerm_data (φs : Array (PropForm Var)) : + arrayConjTerm φs = listConjTerm (φs.data.map (⟦·⟧)) := by + dsimp [arrayConjTerm, listConjTerm] + induction φs.data <;> simp_all + +@[simp] +theorem mk_arrayConj (φs : Array (PropForm Var)) : ⟦arrayConj φs⟧ = arrayConjTerm φs := by + dsimp [arrayConj, listConj, arrayConjTerm] + induction φs.data <;> simp_all + +open PropTerm in +theorem satisfies_arrayConjTerm (φs : Array (PropForm Var)) (τ : PropAssignment Var) : + τ ⊨ arrayConjTerm φs ↔ ∀ φ ∈ φs.data, τ ⊨ ⟦φ⟧ := by + dsimp [arrayConjTerm] + induction φs.data <;> aesop + +def withPolarity (p : PropForm Var) (l : ILit) := cond (l.polarity) p p.neg + +@[simp] theorem withPolarity_mkPos (p : PropForm Var) (x : Var) : + withPolarity p (.mkPos x) = p := by simp [withPolarity] + +@[simp] theorem withPolarity_mkNeg (p : PropForm Var) (x : Var) : + withPolarity p (.mkNeg x) = p.neg := by simp [withPolarity] + +end PropForm + +/- +The current implementation assumes that nodes are added consecutively, without gaps, and throws an +exception otherwise. This enables us to maintain the invariant that the variable (possibly an +extension variable) corresponding to the entry at index `n` is `n + 1`. + +We nonetheless store the variable anyhow, to make it easier to loosen that requirement in the +future. We can do that straightforwardly by adding a hashmap that maps each variable to the +corresponding index. +-/ + +inductive PogElt where + | var : Var → PogElt + | disj : Var → ILit → ILit → PogElt + | conj : Var → Cube → PogElt +deriving Repr, DecidableEq, Inhabited + +namespace PogElt + +def varNum : PogElt → Var + | var x => x + | disj x _ _ => x + | conj x _ => x + +-- If we generalize to let variables come in any order, we need only change this to add the indexing +-- function and require `index left.var < index n`, etc. + +def args_decreasing : PogElt → Prop + | var _ => true + | disj n left right => left.var < n ∧ right.var < n + | conj n args => ∀ i : Fin args.size, args[i].var < n + +end PogElt + +-- To generalize this, add a hashmap for the indexing function. + +structure Pog where + elts : Array PogElt + wf : ∀ i : Fin elts.size, elts[i].args_decreasing + inv : ∀ i : Fin elts.size, i = elts[i].varNum.natPred + +def PogError := String + +instance : ToString PogError where + toString := id + +namespace Pog +open PogElt + +def empty : Pog where + elts := #[] + wf := fun i => i.elim0 + inv := fun i => i.elim0 + +def push (pog : Pog) (pogElt : PogElt) + (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size) : Pog where + elts := pog.elts.push pogElt + wf := by + intro ⟨i, h'⟩ + rw [Array.size_push] at h' + cases (lt_or_eq_of_le (le_of_lt_succ h')) + . case inl h' => + dsimp; rw [Array.get_push_lt _ _ _ h'] + apply pog.wf ⟨i, h'⟩ + . case inr h' => + dsimp; cases h'; rw [Array.get_push_eq] + exact hwf + inv := by + intro ⟨i, h'⟩ + rw [Array.size_push] at h' + cases (lt_or_eq_of_le (le_of_lt_succ h')) + . case inl h' => + dsimp; rw [Array.get_push_lt _ _ _ h'] + apply pog.inv ⟨i, h'⟩ + . case inr h' => + cases h'; dsimp + rw [Array.get_push_eq, hinv, natPred_succPNat] + +theorem get_push_elts_lt (pog : Pog) (pogElt : PogElt) + (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size) + (i : Nat) (h : i < pog.elts.size) (h' : i < (pog.push pogElt hwf hinv).elts.size) : + (pog.push pogElt hwf hinv).elts[i] = pog.elts[i] := + Array.get_push_lt _ _ _ h + +lemma get_push_elts_nat_Pred_varNum (pog : Pog) (pogElt : PogElt) + (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size) + (h' : PNat.natPred (varNum pogElt) < Array.size (push pog pogElt hwf hinv).elts) : + (pog.push pogElt hwf hinv).elts[PNat.natPred pogElt.varNum] = pogElt := by + simp only [hinv, natPred_succPNat] + apply Array.get_push_eq + +def size_push_elts (pog : Pog) (pogElt : PogElt) + (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size) : + (pog.push pogElt hwf hinv).elts.size = pog.elts.size + 1 := + Array.size_push _ _ + +def addVar (pog : Pog) (x : Var) : Except PogError Pog := + if h : x = succPNat pog.elts.size then + .ok <| pog.push (var x) (by trivial) h + else + .error s!"Pog variable {x} added, {pog.elts.size + 1} expected" + +def addDisj (pog : Pog) (x : Var) (left right : ILit) : Except PogError Pog := + if h : x = succPNat pog.elts.size then + if hleft : left.var < x then + if hright : right.var < x then + .ok <| pog.push (disj x left right) ⟨hleft, hright⟩ h + else + .error s!"Pog disjunction {x} added, right argument {right} missing" + else + .error s!"Pog disjunction {x} added, left argument {left} missing" + else + .error s!"Pog disjunction {x} added, {pog.elts.size + 1} expected" + +def addConj (pog : Pog)(x : Var) (args : Cube) : Except PogError Pog := + if h : x = succPNat pog.elts.size then + if hargs : ∀ i : Fin args.size, args[i].var < x then + .ok <| pog.push (conj x args) hargs h + else + .error s!"Pog conjunction {x} added, argument missing" + else + .error s!"Pog conjunction {x} added, {pog.elts.size + 1} expected" + +/-- This avoids having to repeat a calculation. -/ +lemma lt_aux {n : Nat} {y : Var} (hlt: y < x) (hinv: n = x.natPred) : + y.natPred < n := by rwa [hinv, PNat.natPred_lt_natPred] + +def toPropForm (pog : Pog) (l : ILit) : PropForm Var := + if h : l.var.natPred < pog.elts.size then + aux l.var.natPred h |>.withPolarity l + else + l.toPropForm +where + aux : (i : Nat) → i < pog.elts.size → PropForm Var + | i, h => + match pog.elts[i], pog.wf ⟨i, h⟩, pog.inv ⟨i, h⟩ with + | var x, _, _ => PropForm.var x + | disj x left right, ⟨hleft, hright⟩, hinv => + have h_left_lt : left.var.natPred < i := lt_aux hleft hinv + have h_right_lt : right.var.natPred < i := lt_aux hright hinv + .disj (aux _ (h_left_lt.trans h) |>.withPolarity left) + (aux _ (h_right_lt.trans h) |>.withPolarity right) + | conj x args, hwf, hinv => + .arrayConj <| Array.ofFn fun (j : Fin args.size) => + have h_lt : args[j].var.natPred < i := lt_aux (hwf j) hinv + aux args[j].var.natPred (h_lt.trans h) |>.withPolarity args[j] + +theorem toPropForm_of_polarity_eq_false (pog : Pog) (l : ILit) (hl : l.polarity = false) : + pog.toPropForm l = .neg (pog.toPropForm (-l)) := by + rw [toPropForm] + split + . next h => + rw [toPropForm, ILit.var_negate, dif_pos h, PropForm.withPolarity, hl, cond_false, + PropForm.withPolarity, ILit.polarity_negate, hl, Bool.not_false, cond_true] + . next h => + rw [toPropForm, ILit.var_negate, dif_neg h] + rw [ILit.toPropForm, hl]; simp only [ite_false, PropForm.neg.injEq] + rw [ILit.toPropForm, ILit.polarity_negate, hl]; simp only [ILit.var_negate, ite_true] + +theorem toPropForm_aux_eq (pog : Pog) (i : Nat) (h : i < pog.elts.size) : + toPropForm.aux pog i h = + match pog.elts[i] with + | var x => PropForm.var x + | disj _ left right => .disj (pog.toPropForm left) (pog.toPropForm right) + | conj _ args => + .arrayConj <| Array.ofFn fun (j : Fin args.size) => pog.toPropForm args[j] := by + rw [toPropForm.aux] + split + . simp [*] + . next x left right hleft hright hinv heq _ _ => + simp only [heq] + have h_left_lt : left.var.natPred < i := lt_aux hleft hinv + have h_right_lt : right.var.natPred < i := lt_aux hright hinv + rw [toPropForm, dif_pos (h_left_lt.trans h), toPropForm, dif_pos (h_right_lt.trans h)] + . next x args hwf hinv heq _ _ => + simp only [heq] + congr; ext j + have h_lt : args[j].var.natPred < i := lt_aux (hwf j) hinv + rw [toPropForm, dif_pos (h_lt.trans h)] + +theorem toPropForm_push_of_lt (pog : Pog) (pogElt : PogElt) + (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size) + (l : ILit) (hl : PNat.natPred l.var < pog.elts.size) : + (pog.push pogElt hwf hinv).toPropForm l = pog.toPropForm l := by + have hl' : PNat.natPred l.var < (pog.push pogElt hwf hinv).elts.size := by + dsimp [Pog.push]; rw [Array.size_push]; exact hl.trans (lt_succ_self _) + rw [toPropForm, toPropForm, dif_pos hl, dif_pos hl', aux] +where + aux : + (i : Nat) → (h : i < pog.elts.size) → (h' : i < (pog.push pogElt hwf hinv).elts.size) → + toPropForm.aux (pog.push pogElt hwf hinv) i h' = toPropForm.aux pog i h + | i, h, h' => by + rw [toPropForm.aux]; conv => rhs; rw [toPropForm.aux] + have heq := pog.get_push_elts_lt pogElt hwf hinv i h h' + split <;> split <;> simp [*] at heq <;> try { injection heq } <;> try { simp only [heq] } + . next x left right hleft hright hinv' _ _ _ => + simp only [heq] + have _ : left.var.natPred < i := by + dsimp at hinv'; rwa [hinv', PNat.natPred_lt_natPred] + have _ : right.var.natPred < i := by + dsimp at hinv'; rwa [hinv', PNat.natPred_lt_natPred] + rw [aux (PNat.natPred (ILit.var left)), aux (PNat.natPred (ILit.var right))] + . next x args hargs hinv' _ _ _ _ _ _ x' args' _ _ _ _ _ => + cases heq.2 + cases heq.1 + apply congr_arg PropForm.arrayConj + apply congr_arg Array.ofFn + ext j; dsimp + have _ : args[j].var.natPred < i := by + dsimp at hinv'; rw [hinv', PNat.natPred_lt_natPred] + exact hargs j + rw [aux (PNat.natPred (ILit.var _))] + +theorem toPropForm_push_of_ne (y : Var) (pog : Pog) (pogElt : PogElt) + (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size) + (hne : pogElt.varNum ≠ y) : + (pog.push pogElt hwf hinv).toPropForm (.mkPos y) = pog.toPropForm (.mkPos y) := by + rw [toPropForm, toPropForm] + simp only [ILit.var_mkPos, PropForm.withPolarity_mkPos] + cases le_or_gt pogElt.varNum y + case inl hle => + have : Array.size pog.elts ≤ PNat.natPred y := + by rwa [←succPNat_le_succPNat, ←hinv, PNat.succPNat_natPred] + rw [dif_neg (not_lt_of_le this), dif_neg] + rw [not_lt, size_push_elts, succ_le_iff] + apply (lt_of_le_of_ne this) + contrapose! hne + rw [hinv, hne, PNat.succPNat_natPred] + case inr hle => + have : PNat.natPred y < Array.size pog.elts := + by rwa [←succPNat_lt_succPNat, ←hinv, PNat.succPNat_natPred] + rw [dif_pos this, dif_pos, toPropForm_push_of_lt.aux] + rw [size_push_elts] + apply lt_succ_of_lt this + +theorem toPropForm_empty (l : ILit) : empty.toPropForm l = l.toPropForm := by + dsimp [toPropForm] + split + next h => + simp [empty] at h + next => + rfl + +theorem toPropForm_neg (p : Pog) (x : Var) : + p.toPropForm (.mkNeg x) = .neg (p.toPropForm (.mkPos x)) := by + rw [toPropForm, toPropForm]; simp; split <;> simp [ILit.toPropForm] + +theorem toPropForm_addVar (p p' : Pog) (x : Var) : + p.addVar x = .ok p' → + p'.toPropForm (.mkPos x) = .var x := by + rw [addVar] + split + . next h => + intro h' + injection h' with h' + rw [←h', toPropForm] + split + . next h'' => + rw [toPropForm.aux] + have heq : ∀ h1 h2, + (push p (var x) h1 h2).elts[PNat.natPred (ILit.var (ILit.mkPos x))] = var x := + fun h1 h2 => get_push_elts_nat_Pred_varNum _ _ _ _ _ + split <;> simp only [heq] at * + next x' _ _ _ _ heq' => + injection heq' with heq' + simp [heq'] + . simp [ILit.toPropForm] + . intro; contradiction + +theorem toPropForm_addVar_lit (p p' : Pog) (l : ILit) : + p.addVar l.var = .ok p' → + p'.toPropForm l = l.toPropForm := by + cases l.mkPos_or_mkNeg <;> + next hMk => + intro h + rw [hMk] + have := toPropForm_addVar _ _ _ h + simp [toPropForm_neg, this] + +theorem toPropForm_addVar_of_ne (x y : Var) (p p' : Pog) : + p.addVar x = .ok p' → x ≠ y → + p'.toPropForm (.mkPos y) = p.toPropForm (.mkPos y) := by + rw [addVar] + split + . next h => + intro h' + injection h' with h' + intro hne + rw [←h'] + apply toPropForm_push_of_ne + exact hne + . intro; contradiction + +theorem toPropForm_addVar_lit_of_ne (x : Var) (l : ILit) (p p' : Pog) : + p.addVar x = .ok p' → x ≠ l.var → + p'.toPropForm l = p.toPropForm l := by + cases l.mkPos_or_mkNeg <;> + next hMk => + intro h hNe + rw [hMk] + have := toPropForm_addVar_of_ne _ _ _ _ h hNe + simp [toPropForm_neg, this] + +theorem toPropForm_addDisj (x : Var) (l₁ l₂ : ILit) (p p' : Pog) : + p.addDisj x l₁ l₂ = .ok p' → + p'.toPropForm (.mkPos x) = .disj (p.toPropForm l₁) (p.toPropForm l₂) := by + rw [addDisj] + split + . next h => + split + . next hleft => + split + . next hright => + intro h' + injection h' with h' + rw [←h', toPropForm] + split + . next h'' => + rw [toPropForm.aux] + have heq : ∀ h1 h2, + (push p (disj x l₁ l₂) h1 h2).elts[PNat.natPred (ILit.var (ILit.mkPos x))] = + disj x l₁ l₂ := + fun h1 h2 => get_push_elts_nat_Pred_varNum _ _ _ _ _ + split <;> simp only [heq] at * + next x' left' right' _ _ _ _ _ heq' => + injection heq' with heq₁ heq₂ heq₃ + cases heq₁ + cases heq₂ + cases heq₃ + simp only [PropForm.withPolarity_mkPos, PropForm.disj.injEq] + constructor + . rw [toPropForm, dif_pos, toPropForm_push_of_lt.aux] + rwa [←succPNat_lt_succPNat, PNat.succPNat_natPred, ←h] + . rw [toPropForm, dif_pos, toPropForm_push_of_lt.aux] + rwa [←succPNat_lt_succPNat, PNat.succPNat_natPred, ←h] + . next h'' => + exfalso + apply h'' + rw [size_push_elts, h, ILit.var_mkPos, natPred_succPNat] + exact lt_succ_self _ + . intro; contradiction + . intro; contradiction + . intro; contradiction + +theorem toPropForm_addDisj_of_ne (x y : Var) (l₁ l₂ : ILit) (p p' : Pog) : + p.addDisj x l₁ l₂ = .ok p' → x ≠ y → + p'.toPropForm (.mkPos y) = p.toPropForm (.mkPos y) := by + rw [addDisj] + split + . next h => + split + . next hleft => + split + . next hright => + intro h' + injection h' with h' + intro hne + rw [←h'] + apply toPropForm_push_of_ne + exact hne + . intro; contradiction + . intro; contradiction + . intro; contradiction + +theorem toPropForm_addDisj_lit_of_ne (x : Var) (l l₁ l₂ : ILit) (p p' : Pog) : + p.addDisj x l₁ l₂ = .ok p' → x ≠ l.var → + p'.toPropForm l = p.toPropForm l := by + cases l.mkPos_or_mkNeg <;> + next hMk => + intro h hNe + rw [hMk] + have := p.toPropForm_addDisj_of_ne _ _ _ _ _ h hNe + simp [toPropForm_neg, this] + +theorem toPropForm_addConj (x : Var) (ls : Array ILit) (p p' : Pog) : + p.addConj x ls = .ok p' → + p'.toPropForm (.mkPos x) = .arrayConj (ls.map p.toPropForm) := by + rw [addConj] + split + . next h => + split + . next hargs => + intro h' + injection h' with h' + rw [←h', toPropForm] + split + . next h'' => + rw [toPropForm.aux] + have heq : ∀ h1 h2, + (push p (conj x ls) h1 h2).elts[PNat.natPred (ILit.var (ILit.mkPos x))] = + conj x ls := + fun h1 h2 => get_push_elts_nat_Pred_varNum _ _ _ _ _ + split <;> simp only [heq] at * + next x' ls' _ _ _ _ _ heq' => + injection heq' with heq₁ heq₂ + cases heq₁ + cases heq₂ + simp only [PropForm.withPolarity_mkPos, PropForm.conj.injEq] + congr + apply Array.ext + . rw [Array.size_map, Array.size_ofFn] + . intro j hj₁ hj₂ + simp only [getElem_fin, Array.getElem_ofFn, Array.getElem_map] + rw [toPropForm, dif_pos, toPropForm_push_of_lt.aux] + rw [←succPNat_lt_succPNat, PNat.succPNat_natPred, ←h] + rw [Array.size_ofFn] at hj₁ + apply hargs ⟨j, hj₁⟩ + . next h'' => + exfalso + apply h'' + rw [size_push_elts, h, ILit.var_mkPos, natPred_succPNat] + exact lt_succ_self _ + . intro; contradiction + . intro; contradiction + +theorem toPropForm_addConj_of_ne (x y : Var) (ls : Array ILit) (p p' : Pog) : + p.addConj x ls = .ok p' → x ≠ y → + p'.toPropForm (.mkPos y) = p.toPropForm (.mkPos y) := by + rw [addConj] + split + . next h => + split + . next args => + intro h' + injection h' with h' + intro hne + rw [←h'] + apply toPropForm_push_of_ne + exact hne + . intro; contradiction + . intro; contradiction + +theorem toPropForm_addConj_lit_of_ne (x : Var) (l : ILit) (ls : Array ILit) (p p' : Pog) : + p.addConj x ls = .ok p' → x ≠ l.var → + p'.toPropForm l = p.toPropForm l := by + cases l.mkPos_or_mkNeg <;> + next hMk => + intro h hNe + rw [hMk] + have := p.toPropForm_addConj_of_ne _ _ _ _ h hNe + simp [toPropForm_neg, this] + +/- +Even though we are not using this now, a Pog can keep track of its variables, and if the client +can ensure that conjunctions and disjunctions refer to previous variables, we can eliminate the +checks in `addDisj` and `addConj`. +-/ + +def vars (pog : Pog) : Finset Var := Finset.range pog.elts.size |>.image succPNat + +theorem mem_vars_aux {pog : Pog} {n : Var} : n ∈ pog.vars ↔ n ≤ pog.elts.size := by + simp only [Pog.vars, Finset.mem_image, Finset.mem_range] + constructor + . rintro ⟨m, hm, rfl⟩ + exact hm + . rintro hle + use n.natPred + rw [lt_iff_add_one_le, ←succ_eq_add_one, ←succPNat_coe, PNat.succPNat_natPred] + exact ⟨hle, rfl⟩ + +theorem mem_vars {pog : Pog} {n : Var} : + n ∈ pog.vars ↔ ∃ i : Fin pog.elts.size, pog.elts[i].varNum = n := by + rw [mem_vars_aux] + constructor + . intro hle + have : n.natPred < pog.elts.size := by + apply lt_of_succ_le + rw [←succPNat_coe, PNat.succPNat_natPred] + exact hle + use ⟨n.natPred, this⟩ + rw [←PNat.natPred_inj] + symm; apply pog.inv ⟨n.natPred, this⟩ + . rintro ⟨i, rfl⟩ + have := congr_arg succPNat (pog.inv i) + rw [PNat.succPNat_natPred] at this + rw [←this, succPNat_coe] + exact i.isLt + +theorem vars_push (pog : Pog) (pogElt : PogElt) + (hwf : args_decreasing pogElt) (hinv : pogElt.varNum = succPNat pog.elts.size) : + vars (pog.push pogElt hwf hinv) = insert (succPNat pog.elts.size) pog.vars := by + ext i + rw [mem_vars_aux, Pog.push, Array.size_push, Finset.mem_insert, mem_vars_aux, + le_iff_eq_or_lt, ←Nat.lt_succ, ←succ_eq_add_one, ←succPNat_coe, PNat.coe_inj] + +theorem vars_addVar {pog newPog : Pog} {n : Var} (h : (pog.addVar n) = .ok newPog) : + newPog.vars = insert n pog.vars := by + rw [addVar] at h + split at h + case inr h' => + contradiction + case inl h' => + ext i + injection h with h + rw [←h, vars_push, h'] + +theorem vars_addDisj {pog newPog : Pog} {n : Var} (left right : ILit) + (h : (pog.addDisj n left right) = .ok newPog) : + newPog.vars = insert n pog.vars := by + rw [addDisj] at h + split at h <;> try { contradiction } + split at h <;> try { contradiction } + split at h <;> try { contradiction } + next h' _ _ => + ext i + injection h with h + rw [←h, vars_push, h'] + +theorem vars_addConj {pog newPog : Pog} {n : Var} (args : Array ILit) + (h : (pog.addConj n args) = .ok newPog) : + newPog.vars = insert n pog.vars := by + rw [addConj] at h + split at h <;> try { contradiction } + split at h <;> try { contradiction } + next h' _ => + ext i + injection h with h + rw [←h, vars_push, h'] + +end Pog \ No newline at end of file diff --git a/Experiments/CPOG/Main.lean b/Experiments/CPOG/Main.lean new file mode 100644 index 0000000..3d5e141 --- /dev/null +++ b/Experiments/CPOG/Main.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import Cli + +import ProofChecker.Checker.Parse +import ProofChecker.Checker.CheckerCore + +def runCheckCmd (p : Cli.Parsed) : IO UInt32 := do + let cnfFname := p.positionalArg! "cnf" + let cpogFname := p.positionalArg! "cpog" + let printFormula := p.hasFlag "print-cnf" + let printProof := p.hasFlag "print-cpog" + let count := p.hasFlag "count" + printlnFlush "Parsing CNF.." + let (cnf, nVars) ← ICnf.readDimacsFile cnfFname.value + IO.println "done." + if printFormula then + IO.println "Parsed CNF:" + IO.print (cnf.toDimacs nVars) + printlnFlush "Parsing CPOG.." + let pf ← CpogStep.readDimacsFile cpogFname.value + IO.println "done." + if printProof then + IO.println "Parsed CPOG:" + for step in pf do + IO.println step.toDimacs + printlnFlush "Checking proof.." + match checkProof cnf nVars pf count with + | .ok v => + IO.println "PROOF SUCCESSFUL" + if count then + IO.println s!"Model count: {v}" + return 0 + | .error e => + IO.println s!"PROOF FAILED\n{e}" + return 1 +where + printlnFlush (s : String) := do + IO.println s + (← IO.getStdout).flush + +def checkCmd : Cli.Cmd := `[Cli| + CheckCPOG VIA runCheckCmd; ["0.1.0"] + "Check a CPOG proof." + + FLAGS: + v, verbose; "Print diagnostic information." + c, count; "Output the unweighted model count." + "print-cnf"; "Reprint the parsed CNF formula." + "print-cpog"; "Reprint the parsed CPOG proof." + + ARGS: + cnf : String; "The CNF input file." + cpog : String; "The CPOG proof file." + + EXTENSIONS: + Cli.author "Wojciech Nawrocki" +] + +def main (args : List String) : IO UInt32 := do + checkCmd.validate args diff --git a/Experiments/CPOG/Model/Cpog.lean b/Experiments/CPOG/Model/Cpog.lean new file mode 100644 index 0000000..9560b66 --- /dev/null +++ b/Experiments/CPOG/Model/Cpog.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import ProofChecker.Data.ICnf +import ProofChecker.Data.Pog +import ProofChecker.Model.PropVars +import ProofChecker.Model.Extensions +import ProofChecker.Count.PropForm + +/-! Justifications of CPOG steps. -/ + +open PropTerm + +theorem addDisj_new_var_equiv {A : Set Var} (Γ l₁ l₂ φ₁ φ₂ : PropTerm Var) : + s ∉ A → X ⊆ A → ↑Γ.semVars ⊆ A → ↑l₁.semVars ⊆ A → ↑l₂.semVars ⊆ A → + equivalentOver X (l₁ ⊓ Γ) φ₁ → equivalentOver X (l₂ ⊓ Γ) φ₂ → + equivalentOver X (.var s ⊓ Γ ⊓ (.biImpl (.var s) (l₁ ⊔ l₂))) (φ₁ ⊔ φ₂) := by + intro hNMem hXA hΓ hL₁ hL₂ e₁ e₂ τ + have hMem : s ∉ X := fun h => absurd (hXA h) hNMem + have hΓ : s ∉ Γ.semVars := fun h => absurd (hΓ h) hNMem + have hL₁ : s ∉ l₁.semVars := fun h => absurd (hL₁ h) hNMem + have hL₂ : s ∉ l₂.semVars := fun h => absurd (hL₂ h) hNMem + constructor + case mp => + intro ⟨σ₁, hAgree, h₁⟩ + simp at h₁ + have : σ₁ ⊨ Γ := by tauto + have : σ₁ ⊨ l₁ ⊔ l₂ := by simp; tauto + cases satisfies_disj.mp this with + | inl h => + have : σ₁ ⊨ l₁ ⊓ Γ := by simp; tauto + have ⟨σ₂, hAgree₂, h₂⟩ := e₁ τ |>.mp ⟨σ₁, hAgree, this⟩ + exact ⟨σ₂, hAgree₂, satisfies_disj.mpr (.inl h₂)⟩ + | inr h => + have : σ₁ ⊨ l₂ ⊓ Γ := by simp; tauto + have ⟨σ₂, hAgree₂, h₂⟩ := e₂ τ |>.mp ⟨σ₁, hAgree, this⟩ + exact ⟨σ₂, hAgree₂, satisfies_disj.mpr (.inr h₂)⟩ + case mpr => + intro ⟨σ₂, hAgree, h₂⟩ + cases satisfies_disj.mp h₂ with + | inl h => + have ⟨σ₁, hAgree₁, h₁⟩ := e₁ τ |>.mpr ⟨σ₂, hAgree, h⟩ + let σ₁' := σ₁.set s ⊤ + have : σ₁' ⊨ .var s := by simp + have hAgree₁' : σ₁'.agreeOn X σ₁ := σ₁.agreeOn_set_of_not_mem _ hMem + have : σ₁'.agreeOn X τ := hAgree₁'.trans hAgree₁ + have : σ₁' ⊨ Γ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hΓ) |>.mpr + (satisfies_conj.mp h₁).right + have : σ₁' ⊨ l₁ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hL₁) |>.mpr + (satisfies_conj.mp h₁).left + exact ⟨σ₁', by assumption, by simp; tauto⟩ + | inr h => + have ⟨σ₁, hAgree₁, h₁⟩ := e₂ τ |>.mpr ⟨σ₂, hAgree, h⟩ + let σ₁' := σ₁.set s true + have : σ₁' ⊨ .var s := by simp + have hAgree₁' : σ₁'.agreeOn X σ₁ := σ₁.agreeOn_set_of_not_mem _ hMem + have : σ₁'.agreeOn X τ := hAgree₁'.trans hAgree₁ + have : σ₁' ⊨ Γ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hΓ) |>.mpr + (satisfies_conj.mp h₁).right + have : σ₁' ⊨ l₂ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hL₂) |>.mpr + (satisfies_conj.mp h₁).left + exact ⟨σ₁', by assumption, by simp; tauto⟩ + +theorem addDisj_partitioned {A : Set Var} (Γ l₁ l₂ : PropTerm Var) (φ₁ φ₂ : PropForm Var) : + -- Note: also works with l₁.semVars ⊆ A + ↑l₂.semVars ⊆ A → hasUniqueExtension X A Γ → + Γ ⊓ l₁ ⊓ l₂ ≤ ⊥ → equivalentOver X (l₁ ⊓ Γ) ⟦φ₁⟧ → equivalentOver X (l₂ ⊓ Γ) ⟦φ₂⟧ → + φ₁.partitioned → φ₂.partitioned → (φ₁.disj φ₂).partitioned := by + intro hL₂ hUep hImp e₁ e₂ hD₁ hD₂ + refine ⟨hD₁, hD₂, fun τ ⟨h₁, h₂⟩ => ?_⟩ + have h₁ : τ ⊨ ⟦φ₁⟧ := h₁ + have h₂ : τ ⊨ ⟦φ₂⟧ := h₂ + have ⟨σ₁, hAgree₁, hσ₁⟩ := e₁ τ |>.mpr ⟨τ, PropAssignment.agreeOn_refl _ _, h₁⟩ + have ⟨σ₂, hAgree₂, hσ₂⟩ := e₂ τ |>.mpr ⟨τ, PropAssignment.agreeOn_refl _ _, h₂⟩ + simp at hσ₁ hσ₂ + have hσ₁Γ : σ₁ ⊨ Γ := by tauto + have hσ₂Γ : σ₂ ⊨ Γ := by tauto + have hAgree : σ₁.agreeOn A σ₂ := hUep hσ₁Γ hσ₂Γ (hAgree₁.trans hAgree₂.symm) + have : σ₂ ⊨ l₂ := by tauto + have : σ₁ ⊨ l₂ := agreeOn_semVars (hAgree.subset hL₂) |>.mpr this + have : σ₁ ⊨ ⊥ := entails_ext.mp hImp _ (by simp; tauto) + simp at this + +-- Alternative: use disjoint variables condition on φ₁/φ₂ to put together pair of assignments?! +theorem addConj_new_var_equiv₂ {A : Set Var} (Γ l₁ l₂ φ₁ φ₂ : PropTerm Var) : + -- Note: also works with φ₁.semVars ⊆ X + p ∉ X → p ∉ Γ.semVars → p ∉ l₁.semVars → p ∉ l₂.semVars → φ₂.semVars ⊆ X → + -- Note: also works with l₁.semVars ⊆ A + ↑l₂.semVars ⊆ A → hasUniqueExtension X A Γ → + equivalentOver X (l₁ ⊓ Γ) φ₁ → equivalentOver X (l₂ ⊓ Γ) φ₂ → + equivalentOver X (.var p ⊓ (.biImpl (.var p) (l₁ ⊓ l₂)) ⊓ Γ) (φ₁ ⊓ φ₂) := by + intro hMem hΓ hL₁ hL₂ hφ₂ hL₂Γ hUep e₁ e₂ τ + constructor + case mp => + intro ⟨σ₁, hAgree, h₁⟩ + simp at h₁ + have ⟨σ₂, hAgree₂, h₂⟩ := e₁ τ |>.mp ⟨σ₁, hAgree, by simp; tauto⟩ + have ⟨σ₂', hAgree₂', h₂'⟩ := e₂ τ |>.mp ⟨σ₁, hAgree, by simp; tauto⟩ + have : σ₂.agreeOn X σ₂' := hAgree₂.trans hAgree₂'.symm + have : σ₂ ⊨ φ₂ := agreeOn_semVars (this.subset hφ₂) |>.mpr h₂' + exact ⟨σ₂, hAgree₂, by simp; tauto⟩ + case mpr => + intro ⟨σ₂, hAgree, h₂⟩ + simp at h₂ + have ⟨σ₁, hAgree₁, h₁⟩ := e₁ τ |>.mpr ⟨σ₂, hAgree, by tauto⟩ + have ⟨σ₁', hAgree₁', h₁'⟩ := e₂ τ |>.mpr ⟨σ₂, hAgree, by tauto⟩ + simp at h₁ h₁' + have hσ₁Γ : σ₁ ⊨ Γ := by tauto + have hσ₁'Γ : σ₁' ⊨ Γ := by tauto + have hAgree₁₁' : σ₁.agreeOn A σ₁' := hUep hσ₁Γ hσ₁'Γ (hAgree₁.trans hAgree₁'.symm) + have : σ₁ ⊨ l₂ := agreeOn_semVars (hAgree₁₁'.subset hL₂Γ) |>.mpr (by tauto) + let σ₃ := σ₁.set p true + have : σ₃ ⊨ .var p := by simp + have : σ₃ ⊨ l₁ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hL₁) |>.mpr (by tauto) + have : σ₃ ⊨ l₂ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hL₂) |>.mpr (by tauto) + have : σ₃ ⊨ Γ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hΓ) |>.mpr (by tauto) + exact ⟨σ₃, σ₁.agreeOn_set_of_not_mem _ hMem |>.trans hAgree₁, by simp; tauto⟩ + +theorem addConj_new_var_equiv {A : Set Var} (G : Pog) (Γ : PropTerm Var) (ls : Array ILit) : + p ∉ A → X ⊆ A → ↑Γ.semVars ⊆ A → hasUniqueExtension X A Γ → + (∀ σ₁, ∃ (σ₂ : PropAssignment Var), σ₂.agreeOn X σ₁ ∧ σ₂ ⊨ Γ) → + (∀ l ∈ ls.data, l.var ∈ A ∧ ↑(PropTerm.semVars ⟦G.toPropForm l⟧) ⊆ X ∧ + equivalentOver X (l.toPropTerm ⊓ Γ) ⟦G.toPropForm l⟧) → + equivalentOver X + (.var p ⊓ (Γ ⊓ .biImpl (.var p) ⟦PropForm.arrayConj (ls.map ILit.toPropForm)⟧)) + ⟦PropForm.arrayConj (ls.map G.toPropForm)⟧ := by + intro hMem hX hΓ hUep hExt hLs τ + refine ⟨?mp, ?mpr⟩ <;> + simp only [PropForm.mk_arrayConj, satisfies_conj, satisfies_biImpl, + PropForm.satisfies_arrayConjTerm, Array.map_data, List.mem_map', and_imp, + forall_apply_eq_imp_iff₂, forall_exists_index, ILit.mk_toPropForm] + case mp => + intro σ₁ hAgree hσ₁p hσ₁Γ hσ₁ + simp only [hσ₁p, true_iff, ILit.mk_toPropForm] at hσ₁ + refine ⟨σ₁, hAgree, ?_⟩ + intro l hL + have ⟨_, hTpf, hEquiv⟩ := hLs l hL + have : σ₁ ⊨ l.toPropTerm := hσ₁ l hL + have : σ₁ ⊨ l.toPropTerm ⊓ Γ := by simp [this, hσ₁Γ] + have ⟨σ₂, hAgree₂, hσ₂⟩ := hEquiv τ |>.mp ⟨σ₁, hAgree, this⟩ + apply agreeOn_semVars ?_ |>.mp hσ₂ + exact (hAgree₂.trans hAgree.symm).subset hTpf + case mpr => + intro σ₂ hAgree₂ hTpfs + have ⟨σ₁, hAgree₁, h₁⟩ := hExt τ + let σ₁' := σ₁.set p true + have hσ₁'p : σ₁' ⊨ .var p := by simp + have hAgree₁'A : σ₁'.agreeOn A σ₁ := σ₁.agreeOn_set_of_not_mem _ hMem + have hAgree₁' : σ₁'.agreeOn X τ := hAgree₁'A.subset hX |>.trans hAgree₁ + have hσ₁'Γ : σ₁' ⊨ Γ := agreeOn_semVars (hAgree₁'A.subset hΓ) |>.mpr h₁ + refine ⟨σ₁', hAgree₁', hσ₁'p, hσ₁'Γ, ⟨fun _ => ?_, fun _ => hσ₁'p⟩⟩ + intro l hL + have : σ₂ ⊨ ⟦G.toPropForm l⟧ := hTpfs l hL + have ⟨σ₃, hAgree₃, h₃⟩ := (hLs l hL).right.right τ |>.mpr ⟨σ₂, hAgree₂, this⟩ + refine agreeOn_semVars ?_ |>.mp (satisfies_conj.mp h₃).left + have : ↑l.toPropTerm.semVars ⊆ A := by simp [(hLs l hL).left] + apply PropAssignment.agreeOn.subset this + exact hUep (satisfies_conj.mp h₃).right hσ₁'Γ (hAgree₃.trans hAgree₁'.symm) + +/-! Other stuff that doesn't fit anywhere. -/ + +theorem partitioned_lit (l : ILit) : l.toPropForm.partitioned := by + dsimp [ILit.toPropForm] + cases l.polarity <;> simp [PropForm.partitioned] \ No newline at end of file diff --git a/Experiments/CPOG/Model/Extensions.lean b/Experiments/CPOG/Model/Extensions.lean new file mode 100644 index 0000000..9c7bb32 --- /dev/null +++ b/Experiments/CPOG/Model/Extensions.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import ProofChecker.Model.PropVars + +/-! Reasoning about definitional extensions. -/ + +namespace PropTerm + +variable [DecidableEq ν] + +theorem equivalentOver_def_ext {x : ν} {X : Set ν} (φ ψ : PropTerm ν) : + ↑φ.semVars ⊆ X → ↑ψ.semVars ⊆ X → x ∉ X → equivalentOver X φ (φ ⊓ .biImpl (.var x) ψ) := by + intro hφ hψ hMem τ + constructor + case mp => + intro ⟨σ₁, hAgree, h₁⟩ + let σ₂ := σ₁.set x (ψ.eval σ₁) + have hAgree₂₁ : σ₂.agreeOn X σ₁ := σ₁.agreeOn_set_of_not_mem _ hMem + have : σ₂.agreeOn X τ := hAgree₂₁.trans hAgree + have : σ₂ ⊨ φ := agreeOn_semVars (hAgree₂₁.subset hφ) |>.mpr h₁ + have : σ₂ ⊨ ψ ↔ σ₁ ⊨ ψ := agreeOn_semVars (hAgree₂₁.subset hψ) + have : σ₂ ⊨ .biImpl (.var x) ψ := by aesop + exact ⟨σ₂, by assumption, satisfies_conj.mpr (by constructor <;> assumption)⟩ + case mpr => + intro ⟨σ₂, hAgree, h₂⟩ + exact ⟨σ₂, hAgree, (satisfies_conj.mp h₂).left⟩ + +theorem equivalentOver_def_self {x : ν} {X : Set ν} (φ : PropTerm ν) : + x ∉ X → ↑φ.semVars ⊆ X → equivalentOver X (.var x ⊓ .biImpl (.var x) φ) φ := by + intro hMem hφ τ + constructor + case mp => + intro ⟨σ₁, hAgree, h₁⟩ + simp only [satisfies_conj, satisfies_biImpl] at h₁ + exact ⟨σ₁, hAgree, h₁.right.mp h₁.left⟩ + case mpr => + intro ⟨σ₂, hAgree, h₂⟩ + let σ₁ := σ₂.set x ⊤ + have hAgree₁₂ : σ₁.agreeOn X σ₂ := σ₂.agreeOn_set_of_not_mem _ hMem + have : σ₁.agreeOn X τ := hAgree₁₂.trans hAgree + have : σ₁ ⊨ φ := agreeOn_semVars (hAgree₁₂.subset hφ) |>.mpr h₂ + exact ⟨σ₁, by assumption, satisfies_conj.mpr (by simp (config := {zeta := false}) [this])⟩ + +theorem hasUniqueExtension_def_ext {X : Set ν} (x : ν) (φ ψ : PropTerm ν) : + ↑ψ.semVars ⊆ X → hasUniqueExtension X (insert x X) (φ ⊓ .biImpl (.var x) ψ) := by + intro hψ σ₁ σ₂ h₁ h₂ hAgree + suffices σ₁ ⊨ .var x ↔ σ₂ ⊨ .var x by + intro x h + cases Set.mem_insert_iff.mp h + next h => + simp only [satisfies_var, ← Bool.eq_iff_eq_true_iff] at this + rw [h, this] + next h => exact hAgree _ h + have := agreeOn_semVars (hAgree.subset hψ) + constructor <;> simp_all + +theorem disj_def_eq (x : ν) (φ₁ φ₂ : PropTerm ν) : + ((.var x)ᶜ ⊔ (φ₁ ⊔ φ₂)) ⊓ ((.var x ⊔ φ₁ᶜ) ⊓ (.var x ⊔ φ₂ᶜ)) = .biImpl (.var x) (φ₁ ⊔ φ₂) := by + ext τ + cases h : τ x <;> simp [not_or, h] + +theorem equivalentOver_disj_def_ext {x : ν} {X : Set ν} (φ φ₁ φ₂ : PropTerm ν) : + ↑φ.semVars ⊆ X → ↑φ₁.semVars ⊆ X → ↑φ₂.semVars ⊆ X → x ∉ X → + equivalentOver X φ (φ ⊓ ((.var x)ᶜ ⊔ φ₁ ⊔ φ₂) ⊓ (.var x ⊔ φ₁ᶜ) ⊓ (.var x ⊔ φ₂ᶜ)) := by + intro hφ h₁ h₂ hMem + simp [sup_assoc, inf_assoc, disj_def_eq] + have := Finset.coe_subset.mpr (semVars_disj φ₁ φ₂) + apply equivalentOver_def_ext _ _ hφ (subset_trans this (by simp [*])) hMem + +-- TODO: bigConj_def_eq + +end PropTerm \ No newline at end of file diff --git a/Experiments/CPOG/Model/PropForm.lean b/Experiments/CPOG/Model/PropForm.lean new file mode 100644 index 0000000..bc239d4 --- /dev/null +++ b/Experiments/CPOG/Model/PropForm.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import Mathlib.Data.Set.Basic +import Mathlib.Order.BooleanAlgebra + +import ProofChecker.Model.ToMathlib + +/-! Formulas of propositional logic. -/ + +/-- A propositional formula over variables of type `ν`. -/ +inductive PropForm (ν : Type u) + | var (x : ν) + | tr + | fls + | neg (φ : PropForm ν) + | conj (φ₁ φ₂ : PropForm ν) + | disj (φ₁ φ₂ : PropForm ν) + | impl (φ₁ φ₂ : PropForm ν) + | biImpl (φ₁ φ₂ : PropForm ν) + deriving Repr, DecidableEq, Inhabited + +namespace PropForm + +-- HACK: a `let` doesn't work with structural recursion +local macro "go " n:ident : term => + `(let s := $(Lean.mkIdent `PropForm.toString) $n + if s.contains ' ' then s!"({s})" else s) +protected def toString [ToString ν] : PropForm ν → String + | var x => toString x + | tr => "⊤" + | fls => "⊥" + | neg φ => s!"¬{go φ}" + | conj φ₁ φ₂ => s!"{go φ₁} ∧ {go φ₂}" + | disj φ₁ φ₂ => s!"{go φ₁} ∨ {go φ₂}" + | impl φ₁ φ₂ => s!"{go φ₁} → {go φ₂}" + | biImpl φ₁ φ₂ => s!"{go φ₁} ↔ {go φ₂}" + +instance [ToString ν] : ToString (PropForm ν) := + ⟨PropForm.toString⟩ + +end PropForm + +/-- An assignment of truth values to propositional variables. -/ +def PropAssignment (ν : Type u) := ν → Bool + +namespace PropAssignment + +@[ext] theorem ext (v1 v2 : PropAssignment ν) (h : ∀ x, v1 x = v2 x) : v1 = v2 := funext h + +def set [DecidableEq ν] (τ : PropAssignment ν) (x : ν) (v : Bool) : + PropAssignment ν := + fun y => if y = x then v else τ y + +@[simp] +theorem set_get [DecidableEq ν] (τ : PropAssignment ν) (x : ν) (v : Bool) : + τ.set x v x = v := by + simp [set] + +theorem set_get_of_ne [DecidableEq ν] {x y : ν} (τ : PropAssignment ν) (v : Bool) : + x ≠ y → τ.set x v y = τ y := by + intro h + simp [set, h.symm] + +@[simp] +theorem set_set [DecidableEq ν] (τ : PropAssignment ν) (x : ν) (v v' : Bool) : + (τ.set x v).set x v' = τ.set x v' := by + ext x' + dsimp [set]; split <;> simp_all + +@[simp] +theorem set_same [DecidableEq ν] (τ : PropAssignment ν) (x : ν) : + τ.set x (τ x) = τ := by + ext x' + dsimp [set]; split <;> simp_all + +end PropAssignment + +namespace PropForm + +/-- The unique evaluation function on formulas which extends `τ`. -/ +@[simp] +def eval (τ : PropAssignment ν) : PropForm ν → Bool + | var x => τ x + | tr => true + | fls => false + | neg φ => !(eval τ φ) + | conj φ₁ φ₂ => (eval τ φ₁) && (eval τ φ₂) + | disj φ₁ φ₂ => (eval τ φ₁) || (eval τ φ₂) + | impl φ₁ φ₂ => (eval τ φ₁) ⇨ (eval τ φ₂) + | biImpl φ₁ φ₂ => eval τ φ₁ = eval τ φ₂ + +/-! Satisfying assignments -/ + +/-- An assignment satisfies a formula `φ` when `φ` evaluates to `⊤` at that assignment. -/ +def satisfies (τ : PropAssignment ν) (φ : PropForm ν) : Prop := + φ.eval τ = true + +/-- This instance is scoped so that `τ ⊨ φ : Prop` implies `φ : PropForm _` via the `outParam` only +when `PropForm` is open. -/ +scoped instance : SemanticEntails (PropAssignment ν) (PropForm ν) where + entails := PropForm.satisfies + +open SemanticEntails renaming entails → sEntails + +variable {τ : PropAssignment ν} {x : ν} {φ φ₁ φ₂ φ₃ : PropForm ν} + +@[simp] +theorem satisfies_var : τ ⊨ var x ↔ τ x := by + simp [sEntails, satisfies] + +@[simp] +theorem satisfies_tr : τ ⊨ tr := by + simp [sEntails, satisfies] + +@[simp] +theorem not_satisfies_fls : τ ⊭ fls := + fun h => nomatch h + +@[simp] +theorem satisfies_neg : τ ⊨ neg φ ↔ τ ⊭ φ := by + simp [sEntails, satisfies] + +@[simp] +theorem satisfies_conj : τ ⊨ conj φ₁ φ₂ ↔ τ ⊨ φ₁ ∧ τ ⊨ φ₂ := by + simp [sEntails, satisfies] + +@[simp] +theorem satisfies_disj : τ ⊨ disj φ₁ φ₂ ↔ τ ⊨ φ₁ ∨ τ ⊨ φ₂ := by + simp [sEntails, satisfies] + +@[simp] +theorem satisfies_impl : τ ⊨ impl φ₁ φ₂ ↔ (τ ⊨ φ₁ → τ ⊨ φ₂) := by + simp only [sEntails, satisfies, eval] + cases (eval τ φ₁) <;> simp [himp_eq] + +theorem satisfies_impl' : τ ⊨ impl φ₁ φ₂ ↔ τ ⊭ φ₁ ∨ τ ⊨ φ₂ := by + simp only [sEntails, satisfies, eval] + cases (eval τ φ₁) <;> simp [himp_eq] + +@[simp] +theorem satisfies_biImpl : τ ⊨ biImpl φ₁ φ₂ ↔ (τ ⊨ φ₁ ↔ τ ⊨ φ₂) := by + simp [sEntails, satisfies] + +theorem satisfies_biImpl' : τ ⊨ biImpl φ₁ φ₂ ↔ ((τ ⊨ φ₁ ∧ τ ⊨ φ₂) ∨ (τ ⊭ φ₁ ∧ τ ⊭ φ₂)) := by + simp only [sEntails, satisfies, eval] + cases (eval τ φ₁) <;> aesop + +/-! Semantic entailment and equivalence. -/ + +/-- A formula `φ₁` semantically entails `φ₂` when `τ ⊨ φ₁` implies `τ ⊨ φ₂`. + +This is actually defined in terms of the Boolean lattice and the above statement is a theorem. +Note that the two-valued Boolean model is universal, so this formulation of semantic entailment +is equivalent to entailment in every Boolean algebra, and also (by completeness) to provability. -/ +def entails (φ₁ φ₂ : PropForm ν) : Prop := + ∀ (τ : PropAssignment ν), φ₁.eval τ ≤ φ₂.eval τ + +/-- An equivalent formulation of semantic entailment in terms of satisfying assignments. -/ +theorem entails_ext : entails φ₁ φ₂ ↔ (∀ (τ : PropAssignment ν), τ ⊨ φ₁ → τ ⊨ φ₂) := by + have : ∀ τ, (φ₁.eval τ → φ₂.eval τ) ↔ φ₁.eval τ ≤ φ₂.eval τ := by + intro τ + cases (eval τ φ₁) + . simp + . simp only [true_implies] + exact ⟨fun h => h ▸ le_rfl, top_unique⟩ + simp [sEntails, entails, satisfies, this] + +theorem entails_refl (φ : PropForm ν) : entails φ φ := + fun _ => le_rfl +theorem entails.trans : entails φ₁ φ₂ → entails φ₂ φ₃ → entails φ₁ φ₃ := + fun h₁ h₂ τ => le_trans (h₁ τ) (h₂ τ) + +theorem entails_tr (φ : PropForm ν) : entails φ tr := + fun _ => le_top +theorem fls_entails (φ : PropForm ν) : entails fls φ := + fun _ => bot_le + +theorem entails_disj_left (φ₁ φ₂ : PropForm ν) : entails φ₁ (disj φ₁ φ₂) := + fun _ => le_sup_left +theorem entails_disj_right (φ₁ φ₂ : PropForm ν) : entails φ₂ (disj φ₁ φ₂) := + fun _ => le_sup_right +theorem disj_entails : entails φ₁ φ₃ → entails φ₂ φ₃ → entails (disj φ₁ φ₂) φ₃ := + fun h₁ h₂ τ => sup_le (h₁ τ) (h₂ τ) + +theorem conj_entails_left (φ₁ φ₂ : PropForm ν) : entails (conj φ₁ φ₂) φ₁ := + fun _ => inf_le_left +theorem conj_entails_right (φ₁ φ₂ : PropForm ν) : entails (conj φ₁ φ₂) φ₂ := + fun _ => inf_le_right +theorem entails_conj : entails φ₁ φ₂ → entails φ₁ φ₃ → entails φ₁ (conj φ₂ φ₃) := + fun h₁ h₂ τ => le_inf (h₁ τ) (h₂ τ) + +theorem entails_disj_conj (φ₁ φ₂ φ₃ : PropForm ν) : + entails (conj (disj φ₁ φ₂) (disj φ₁ φ₃)) (disj φ₁ (conj φ₂ φ₃)) := + fun _ => le_sup_inf + +theorem conj_neg_entails_fls (φ : PropForm ν) : entails (conj φ (neg φ)) fls := + fun τ => BooleanAlgebra.inf_compl_le_bot (eval τ φ) + +theorem tr_entails_disj_neg (φ : PropForm ν) : entails tr (disj φ (neg φ)) := + fun τ => BooleanAlgebra.top_le_sup_compl (eval τ φ) + +/-- Two formulas are semantically equivalent when they always evaluate to the same thing. -/ +def equivalent (φ₁ φ₂ : PropForm ν) : Prop := + ∀ (τ : PropAssignment ν), φ₁.eval τ = φ₂.eval τ + +theorem equivalent_iff_entails : + equivalent φ₁ φ₂ ↔ (entails φ₁ φ₂ ∧ entails φ₂ φ₁) := by + simp only [equivalent, entails] + aesop (add safe le_antisymm) + +theorem equivalent_ext : + equivalent φ₁ φ₂ ↔ (∀ (τ : PropAssignment ν), τ ⊨ φ₁ ↔ τ ⊨ φ₂) := by + simp only [equivalent_iff_entails, entails_ext] + aesop + +theorem equivalent_refl (φ : PropForm ν) : equivalent φ φ := + fun _ => rfl +theorem equivalent.symm : equivalent φ₁ φ₂ → equivalent φ₂ φ₁ := + fun h τ => (h τ).symm +theorem equivalent.trans : equivalent φ₁ φ₂ → equivalent φ₂ φ₃ → equivalent φ₁ φ₃ := + fun h₁ h₂ τ => (h₁ τ).trans (h₂ τ) +theorem entails.antisymm : entails φ₁ φ₂ → entails φ₂ φ₁ → equivalent φ₁ φ₂ := + fun h₁ h₂ => equivalent_iff_entails.mpr ⟨h₁, h₂⟩ + +-- Equivalently, when `impl φ₁ φ₂` always evaluates to `⊤`. + +end PropForm \ No newline at end of file diff --git a/Experiments/CPOG/Model/PropTerm.lean b/Experiments/CPOG/Model/PropTerm.lean new file mode 100644 index 0000000..0af51de --- /dev/null +++ b/Experiments/CPOG/Model/PropTerm.lean @@ -0,0 +1,320 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import ProofChecker.Model.PropForm + +/-! The Lindenbaum-Tarski algebra on propositional logic. We show that it is a Boolean algebra with +ordering given by semantic entailment. -/ + +open PropForm in +instance PropTerm.setoid (ν : Type) : Setoid (PropForm ν) where + r := equivalent + iseqv := { + refl := equivalent_refl + symm := equivalent.symm + trans := equivalent.trans + } + +/-- A propositional term in the algebra is a propositional formula up to semantic equivalence. -/ +-- PropFun ν +def PropTerm ν := Quotient (PropTerm.setoid ν) + +namespace PropTerm + +-- TODO Explain "generalized rewriting with quotient" + +theorem exact {φ₁ φ₂ : PropForm ν} : @Eq (PropTerm ν) ⟦φ₁⟧ ⟦φ₂⟧ → PropForm.equivalent φ₁ φ₂ := + Quotient.exact + +theorem sound {φ₁ φ₂ : PropForm ν} : PropForm.equivalent φ₁ φ₂ → @Eq (PropTerm ν) ⟦φ₁⟧ ⟦φ₂⟧ := + @Quotient.sound _ (PropTerm.setoid ν) _ _ + +def var (x : ν) : PropTerm ν := ⟦.var x⟧ + +def tr : PropTerm ν := ⟦.tr⟧ + +def fls : PropTerm ν := ⟦.fls⟧ + +def neg : PropTerm ν → PropTerm ν := + Quotient.map (.neg ·) (by + intro _ _ h τ + simp [h τ]) + +def conj : PropTerm ν → PropTerm ν → PropTerm ν := + Quotient.map₂ (.conj · ·) (by + intro _ _ h₁ _ _ h₂ τ + simp [h₁ τ, h₂ τ]) + +def disj : PropTerm ν → PropTerm ν → PropTerm ν := + Quotient.map₂ (.disj · ·) (by + intro _ _ h₁ _ _ h₂ τ + simp [h₁ τ, h₂ τ]) + +def impl : PropTerm ν → PropTerm ν → PropTerm ν := + Quotient.map₂ (.impl · ·) (by + intro _ _ h₁ _ _ h₂ τ + simp [h₁ τ, h₂ τ]) + +def biImpl : PropTerm ν → PropTerm ν → PropTerm ν := + Quotient.map₂ (.biImpl · ·) (by + intro _ _ h₁ _ _ h₂ τ + simp [h₁ τ, h₂ τ]) + +/-! Evaluation lifted to the lattice structure. -/ + +-- NOTE: It could be defined directly using surjectivity of ⟦-⟧ instead. +def eval (τ : PropAssignment ν) : PropTerm ν → Bool := + Quotient.lift (PropForm.eval τ) (fun _ _ h => h τ) + +@[simp] +theorem eval_mk (τ : PropAssignment ν) (φ : PropForm ν) : + eval τ ⟦φ⟧ = φ.eval τ := + rfl + +@[simp] +theorem eval_var (τ : PropAssignment ν) (x : ν) : eval τ (var x) = τ x := by + simp [eval, var] + +@[simp] +theorem eval_tr (τ : PropAssignment ν) : eval τ tr = true := by + simp [eval, tr] + +@[simp] +theorem eval_fls (τ : PropAssignment ν) : eval τ fls = false := by + simp [eval, fls] + +@[simp] +theorem eval_neg (τ : PropAssignment ν) (φ : PropTerm ν) : eval τ (neg φ) = !(eval τ φ) := by + have ⟨φ, h⟩ := Quotient.exists_rep φ + simp [← h, eval, neg] + +@[simp] +theorem eval_conj (τ : PropAssignment ν) (φ₁ φ₂ : PropTerm ν) : + eval τ (conj φ₁ φ₂) = (eval τ φ₁ && eval τ φ₂) := by + have ⟨φ₁, h₁⟩ := Quotient.exists_rep φ₁ + have ⟨φ₂, h₂⟩ := Quotient.exists_rep φ₂ + simp [← h₁, ← h₂, conj, eval] + +@[simp] +theorem eval_disj (τ : PropAssignment ν) (φ₁ φ₂ : PropTerm ν) : + eval τ (disj φ₁ φ₂) = (eval τ φ₁ || eval τ φ₂) := by + have ⟨φ₁, h₁⟩ := Quotient.exists_rep φ₁ + have ⟨φ₂, h₂⟩ := Quotient.exists_rep φ₂ + simp [← h₁, ← h₂, eval, disj] + +@[simp] +theorem eval_impl (τ : PropAssignment ν) (φ₁ φ₂ : PropTerm ν) : + eval τ (impl φ₁ φ₂) = (eval τ φ₁) ⇨ (eval τ φ₂) := by + have ⟨φ₁, h₁⟩ := Quotient.exists_rep φ₁ + have ⟨φ₂, h₂⟩ := Quotient.exists_rep φ₂ + simp [← h₁, ← h₂, eval, impl] + +@[simp] +theorem eval_biImpl (τ : PropAssignment ν) (φ₁ φ₂ : PropTerm ν) : + eval τ (biImpl φ₁ φ₂) = (eval τ φ₁ = eval τ φ₂) := by + have ⟨φ₁, h₁⟩ := Quotient.exists_rep φ₁ + have ⟨φ₂, h₂⟩ := Quotient.exists_rep φ₂ + simp [← h₁, ← h₂, eval, biImpl] + +/-! Satisfying assignments -/ + +def satisfies (τ : PropAssignment ν) (φ : PropTerm ν) : Prop := + φ.eval τ = true + +/-- This instance is scoped so that when `PropTerm` is open, `τ ⊨ φ` implies `φ : PropTerm _` +via the `outParam`. -/ +scoped instance : SemanticEntails (PropAssignment ν) (PropTerm ν) where + entails := PropTerm.satisfies + +@[simp] +theorem satisfies_mk {τ : PropAssignment ν} {φ : PropForm ν} : τ ⊨ ⟦φ⟧ ↔ PropForm.satisfies τ φ := + ⟨id, id⟩ + +open SemanticEntails renaming entails → sEntails + +@[ext] +theorem ext : (∀ (τ : PropAssignment ν), τ ⊨ φ₁ ↔ τ ⊨ φ₂) → φ₁ = φ₂ := by + have ⟨φ₁, h₁⟩ := Quotient.exists_rep φ₁ + have ⟨φ₂, h₂⟩ := Quotient.exists_rep φ₂ + simp only [← h₁, ← h₂] + intro h + apply Quotient.sound ∘ PropForm.equivalent_ext.mpr + apply h + +/-! Semantic entailment. -/ + +def entails (φ₁ φ₂ : PropTerm ν) : Prop := + ∀ (τ : PropAssignment ν), φ₁.eval τ ≤ φ₂.eval τ + +@[simp] +theorem entails_mk {φ₁ φ₂ : PropForm ν} : entails ⟦φ₁⟧ ⟦φ₂⟧ ↔ PropForm.entails φ₁ φ₂ := + ⟨id, id⟩ + +theorem entails_ext {φ₁ φ₂ : PropTerm ν} : + entails φ₁ φ₂ ↔ (∀ (τ : PropAssignment ν), τ ⊨ φ₁ → τ ⊨ φ₂) := by + have ⟨φ₁, h₁⟩ := Quotient.exists_rep φ₁ + have ⟨φ₂, h₂⟩ := Quotient.exists_rep φ₂ + simp only [← h₁, ← h₂, entails_mk] + exact PropForm.entails_ext + +theorem entails_refl (φ : PropTerm ν) : entails φ φ := + fun _ => le_rfl +theorem entails.trans : entails φ₁ φ₂ → entails φ₂ φ₃ → entails φ₁ φ₃ := + fun h₁ h₂ τ => le_trans (h₁ τ) (h₂ τ) + +theorem entails_tr (φ : PropTerm ν) : entails φ tr := + fun _ => le_top +theorem fls_entails (φ : PropTerm ν) : entails fls φ := + fun _ => bot_le + +theorem entails_disj_left (φ₁ φ₂ : PropTerm ν) : entails φ₁ (disj φ₁ φ₂) := + fun _ => by simp only [eval_disj]; exact le_sup_left +theorem entails_disj_right (φ₁ φ₂ : PropTerm ν) : entails φ₂ (disj φ₁ φ₂) := + fun _ => by simp only [eval_disj]; exact le_sup_right +theorem disj_entails : entails φ₁ φ₃ → entails φ₂ φ₃ → entails (disj φ₁ φ₂) φ₃ := + fun h₁ h₂ τ => by simp only [eval_disj]; exact sup_le (h₁ τ) (h₂ τ) + +theorem conj_entails_left (φ₁ φ₂ : PropTerm ν) : entails (conj φ₁ φ₂) φ₁ := + fun _ => by simp only [eval_conj]; exact inf_le_left +theorem conj_entails_right (φ₁ φ₂ : PropTerm ν) : entails (conj φ₁ φ₂) φ₂ := + fun _ => by simp only [eval_conj]; exact inf_le_right +theorem entails_conj : entails φ₁ φ₂ → entails φ₁ φ₃ → entails φ₁ (conj φ₂ φ₃) := + fun h₁ h₂ τ => by simp only [eval_conj]; exact le_inf (h₁ τ) (h₂ τ) + +theorem entails_disj_conj (φ₁ φ₂ φ₃ : PropTerm ν) : + entails (conj (disj φ₁ φ₂) (disj φ₁ φ₃)) (disj φ₁ (conj φ₂ φ₃)) := + fun _ => by simp only [eval_conj, eval_disj]; exact le_sup_inf + +theorem conj_neg_entails_fls (φ : PropTerm ν) : entails (conj φ (neg φ)) fls := + fun τ => by simp only [eval_conj, eval_neg]; exact BooleanAlgebra.inf_compl_le_bot (eval τ φ) + +theorem tr_entails_disj_neg (φ : PropTerm ν) : entails tr (disj φ (neg φ)) := + fun τ => by simp only [eval_disj, eval_neg]; exact BooleanAlgebra.top_le_sup_compl (eval τ φ) + +theorem entails.antisymm : entails φ ψ → entails ψ φ → φ = ψ := by + intro h₁ h₂ + ext τ + exact ⟨entails_ext.mp h₁ τ, entails_ext.mp h₂ τ⟩ + +theorem impl_eq (φ ψ : PropTerm ν) : impl φ ψ = disj ψ (neg φ) := by + ext τ + simp only [sEntails, satisfies, eval_impl, eval_disj, eval_neg] + rfl + +/-! From this point onwards we use lattice notation for `PropTerm`s in order to get all the laws +for free. -/ + +instance : BooleanAlgebra (PropTerm ν) where + le := entails + top := tr + bot := fls + compl := neg + sup := disj + inf := conj + himp := impl + le_refl := entails_refl + le_trans := @entails.trans _ + le_antisymm := @entails.antisymm _ + le_top := entails_tr + bot_le := fls_entails + le_sup_left := entails_disj_left + le_sup_right := entails_disj_right + sup_le _ _ _ := disj_entails + inf_le_left := conj_entails_left + inf_le_right := conj_entails_right + le_inf _ _ _ := entails_conj + le_sup_inf := entails_disj_conj + inf_compl_le_bot := conj_neg_entails_fls + top_le_sup_compl := tr_entails_disj_neg + himp_eq := impl_eq + +@[simp] +theorem satisfies_var {τ : PropAssignment ν} {x : ν} : τ ⊨ var x ↔ τ x := by + simp [sEntails, satisfies] + +@[simp] +theorem satisfies_set {τ : PropAssignment ν} [DecidableEq ν] : τ.set x ⊤ ⊨ var x := by + simp + +@[simp] +theorem satisfies_tr {τ : PropAssignment ν} : τ ⊨ ⊤ := + by simp [sEntails, satisfies, Top.top] + +@[simp] +theorem not_satisfies_fls {τ : PropAssignment ν} : τ ⊭ ⊥ := + fun h => nomatch h + +@[simp] +theorem satisfies_neg {τ : PropAssignment ν} : τ ⊨ (φᶜ) ↔ τ ⊭ φ := by + simp [sEntails, satisfies, HasCompl.compl] + +@[simp] +theorem satisfies_conj {τ : PropAssignment ν} : τ ⊨ φ₁ ⊓ φ₂ ↔ τ ⊨ φ₁ ∧ τ ⊨ φ₂ := by + simp [sEntails, satisfies, HasInf.inf] + +@[simp] +theorem satisfies_disj {τ : PropAssignment ν} : τ ⊨ φ₁ ⊔ φ₂ ↔ τ ⊨ φ₁ ∨ τ ⊨ φ₂ := by + simp [sEntails, satisfies, HasSup.sup] + +@[simp] +theorem satisfies_impl {τ : PropAssignment ν} : τ ⊨ φ₁ ⇨ φ₂ ↔ (τ ⊨ φ₁ → τ ⊨ φ₂) := by + simp only [sEntails, satisfies, eval_impl, HImp.himp] + cases (eval τ φ₁) <;> simp [himp_eq] + +theorem satisfies_impl' {τ : PropAssignment ν} : τ ⊨ φ₁ ⇨ φ₂ ↔ τ ⊭ φ₁ ∨ τ ⊨ φ₂ := by + simp only [sEntails, satisfies, eval_impl, HImp.himp] + cases (eval τ φ₁) <;> simp [himp_eq] + +@[simp] +theorem satisfies_biImpl {τ : PropAssignment ν} : τ ⊨ biImpl φ₁ φ₂ ↔ (τ ⊨ φ₁ ↔ τ ⊨ φ₂) := by + simp [sEntails, satisfies] + +instance : Nontrivial (PropTerm ν) where + exists_pair_ne := by + use ⊤, ⊥ + intro h + have : ∀ (τ : PropAssignment ν), τ ⊨ ⊥ ↔ τ ⊨ ⊤ := fun _ => h ▸ Iff.rfl + simp only [satisfies_tr, not_satisfies_fls] at this + apply this (fun _ => true) + +theorem eq_top_iff {φ : PropTerm ν} : φ = ⊤ ↔ ∀ (τ : PropAssignment ν), τ ⊨ φ := + ⟨fun h => by simp [h], fun h => by ext; simp [h]⟩ + +theorem eq_bot_iff {φ : PropTerm ν} : φ = ⊥ ↔ ∀ (τ : PropAssignment ν), τ ⊭ φ := + ⟨fun h => by simp [h], fun h => by ext; simp [h]⟩ + +theorem biImpl_eq_impls (φ ψ : PropTerm ν) : biImpl φ ψ = (φ ⇨ ψ) ⊓ (ψ ⇨ φ) := by + ext τ + aesop + +/-! Quotient helpers -/ + +-- TODO: custom simp set? + +attribute [-simp] Quotient.eq + +@[simp] +theorem mk_var (x : ν) : ⟦.var x⟧ = var x := rfl + +@[simp] +theorem mk_tr : @Eq (PropTerm ν) ⟦.tr⟧ ⊤ := rfl + +@[simp] +theorem mk_fls : @Eq (PropTerm ν) ⟦.fls⟧ ⊥ := rfl + +@[simp] +theorem mk_neg (φ : PropForm ν) : @Eq (PropTerm ν) ⟦.neg φ⟧ (⟦φ⟧ᶜ) := rfl + +@[simp] +theorem mk_conj (φ₁ φ₂ : PropForm ν) : @Eq (PropTerm ν) ⟦.conj φ₁ φ₂⟧ (⟦φ₁⟧ ⊓ ⟦φ₂⟧) := rfl + +@[simp] +theorem mk_disj (φ₁ φ₂ : PropForm ν) : @Eq (PropTerm ν) ⟦.disj φ₁ φ₂⟧ (⟦φ₁⟧ ⊔ ⟦φ₂⟧) := rfl + +@[simp] +theorem mk_impl (φ₁ φ₂ : PropForm ν) : @Eq (PropTerm ν) ⟦.impl φ₁ φ₂⟧ (⟦φ₁⟧ ⇨ ⟦φ₂⟧) := rfl + +end PropTerm \ No newline at end of file diff --git a/Experiments/CPOG/Model/PropVars.lean b/Experiments/CPOG/Model/PropVars.lean new file mode 100644 index 0000000..3a5f5f4 --- /dev/null +++ b/Experiments/CPOG/Model/PropVars.lean @@ -0,0 +1,399 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import Mathlib.Data.Finset.Basic +import Mathlib.Data.Set.Finite +import Mathlib.Tactic.ByContra + +import ProofChecker.Model.PropTerm + +/-! Definitions and theorems relating propositional formulas and functions to variables + +## Main definitions + +`PropForm.vars` - the set of syntactic variables of a formula +`PropTerm.semVars` - the set of semantic variables of a function +`PropTerm.equivalentOver X` - two functions are equivalent over a set `X` of variables +`PropTerm.hasUniqueExtension X Y` - the assignments to a function extend uniquely from a set `X` to +a set `Y` of variables + +NOTE: Semantic notions are not generally defined on `PropForm`s. They are expected to be used on +`PropForm`s by composing with `⟦-⟧`. + +NOTE: We try to delay talking about dependently-typed functions `{x // x ∈ X} → Bool` for as long as +possible by developing the theory in terms of total assignments `ν → Bool`. Assignments with finite +domain are eventually considered in `ModelCount.lean`. -/ + +namespace PropAssignment + +-- TODO: is this defined in mathlib for functions in general? +def agreeOn (X : Set ν) (σ₁ σ₂ : PropAssignment ν) : Prop := + ∀ x ∈ X, σ₁ x = σ₂ x + +theorem agreeOn_refl (X : Set ν) (σ : PropAssignment ν) : agreeOn X σ σ := + fun _ _ => rfl +theorem agreeOn.symm : agreeOn X σ₁ σ₂ → agreeOn X σ₂ σ₁ := + fun h x hX => Eq.symm (h x hX) +theorem agreeOn.trans : agreeOn X σ₁ σ₂ → agreeOn X σ₂ σ₃ → agreeOn X σ₁ σ₃ := + fun h₁ h₂ x hX => Eq.trans (h₁ x hX) (h₂ x hX) + +theorem agreeOn.subset : X ⊆ Y → agreeOn Y σ₁ σ₂ → agreeOn X σ₁ σ₂ := + fun hSub h x hX => h x (hSub hX) + +theorem agreeOn_empty (σ₁ σ₂ : PropAssignment ν) : agreeOn ∅ σ₁ σ₂ := + fun _ h => False.elim (Set.not_mem_empty _ h) + +variable [DecidableEq ν] + +theorem agreeOn_set_of_not_mem {x : ν} {X : Set ν} (σ : PropAssignment ν) (v : Bool) : x ∉ X → + agreeOn X (σ.set x v) σ := by + -- I ❤ A️esop + aesop (add norm unfold agreeOn, norm unfold set) + +end PropAssignment + +namespace PropForm + +variable [DecidableEq ν] + +/-- Variables appearing in the formula. Sometimes called its "support set". -/ +def vars : PropForm ν → Finset ν + | var y => {y} + | tr | fls => ∅ + | neg φ => vars φ + | conj φ₁ φ₂ | disj φ₁ φ₂ | impl φ₁ φ₂ | biImpl φ₁ φ₂ => vars φ₁ ∪ vars φ₂ + +theorem eval_of_agreeOn_vars {φ : PropForm ν} {σ₁ σ₂ : PropAssignment ν} : σ₁.agreeOn φ.vars σ₂ → + φ.eval σ₁ = φ.eval σ₂ := by + intro h + induction φ <;> simp_all [PropAssignment.agreeOn, eval, vars] + +theorem eval_ext {φ : PropForm ν} {σ₁ σ₂ : PropAssignment ν} : (∀ x ∈ φ.vars, σ₁ x = σ₂ x) → + φ.eval σ₁ = φ.eval σ₂ := + eval_of_agreeOn_vars + +theorem eval_set_of_not_mem_vars {x : ν} {φ : PropForm ν} {τ : PropAssignment ν} : + x ∉ φ.vars → φ.eval (τ.set x b) = φ.eval τ := by + intro hNMem + apply eval_of_agreeOn_vars + intro y hY + have : y ≠ x := fun h => hNMem (h ▸ hY) + simp [PropAssignment.set, this] + +theorem agreeOn_vars {φ : PropForm ν} {σ₁ σ₂ : PropAssignment ν} : + σ₁.agreeOn φ.vars σ₂ → (σ₁ ⊨ φ ↔ σ₂ ⊨ φ) := by + intro h + simp [SemanticEntails.entails, satisfies, eval_of_agreeOn_vars h] + +set_option push_neg.use_distrib true in +lemma mem_vars_of_flip {φ : PropForm ν} {τ : PropAssignment ν} (x : ν) : τ ⊨ φ → + τ.set x (!τ x) ⊭ φ → x ∈ φ.vars := by + intro hτ hτ' + induction φ generalizing τ with + | tr => exfalso; exact hτ' satisfies_tr + | fls => exfalso; exact not_satisfies_fls hτ + | var y => + simp_all only [vars, satisfies_var, Finset.mem_singleton] + by_contra h + exact hτ' (hτ ▸ τ.set_get_of_ne (!τ x) h) + | _ => + simp_all only + [satisfies_conj, satisfies_disj, satisfies_impl', satisfies_biImpl', vars, Finset.mem_union] + push_neg at hτ' + aesop + +theorem exists_flip {φ : PropForm ν} {σ₁ σ₂ : PropAssignment ν} : σ₁ ⊨ φ → σ₂ ⊭ φ → + ∃ (x : ν) (τ : PropAssignment ν), σ₁ x ≠ σ₂ x ∧ τ ⊨ φ ∧ τ.set x (!τ x) ⊭ φ := + fun h₁ h₂ => + let s := φ.vars.filter fun x => σ₁ x ≠ σ₂ x + have hS : ∀ x ∈ s, σ₁ x ≠ σ₂ x := fun _ h => Finset.mem_filter.mp h |>.right + have hSC : ∀ x ∈ φ.vars \ s, σ₁ x = σ₂ x := fun _ h => by simp_all + have ⟨x, τ, hMem, hτ, hτ'⟩ := go h₁ h₂ s hS hSC rfl + ⟨x, τ, hS _ hMem, hτ, hτ'⟩ +-- NOTE(Jeremy): a proof using `Finset.induction` would likely be shorter +where go {σ₁ σ₂ : PropAssignment ν} (h₁ : σ₁ ⊨ φ) (h₂ : σ₂ ⊭ φ) + (s : Finset ν) (hS : ∀ x ∈ s, σ₁ x ≠ σ₂ x) (hSC : ∀ x ∈ φ.vars \ s, σ₁ x = σ₂ x) : + {n : Nat} → s.card = n → + ∃ (x : ν) (τ : PropAssignment ν), x ∈ s ∧ τ ⊨ φ ∧ τ.set x (!τ x) ⊭ φ + | 0, hCard => + -- In the base case, σ₁ and σ₂ agree on all φ.vars, contradiction. + have : s = ∅ := Finset.card_eq_zero.mp hCard + have : σ₁.agreeOn φ.vars σ₂ := fun _ h => by simp_all + have : σ₂ ⊨ φ := (agreeOn_vars this).mp h₁ + False.elim (h₂ this) + | _+1, hCard => by + -- In the inductive case, let σ₁' := σ₁[x₀ ↦ !(σ₁ x₀)] and see if σ₁' satisfies φ or not. + have ⟨x₀, s', h₀, h', hCard'⟩ := Finset.card_eq_succ.mp hCard + have h₀S : x₀ ∈ s := h' ▸ Finset.mem_insert_self x₀ s' + let σ₁' := σ₁.set x₀ (!σ₁ x₀) + by_cases h₁' : σ₁' ⊨ φ + case neg => + -- If σ₁' no longer satisfies φ, we're done. + use x₀, σ₁ + refine ⟨h' ▸ Finset.mem_insert_self x₀ s', h₁, h₁'⟩ + case pos => + -- If σ₁' still satisfies φ, proceed by induction. + have hS' : ∀ x ∈ s', σ₁' x ≠ σ₂ x := fun x hMem => by + have hX : x₀ ≠ x := fun h => h₀ (h ▸ hMem) + simp only [σ₁.set_get_of_ne (!σ₁ x₀) hX] + exact hS _ (h' ▸ Finset.mem_insert_of_mem hMem) + have hSC' : ∀ x ∈ φ.vars \ s', σ₁' x = σ₂ x := fun x hMem => by + by_cases hX : x₀ = x + case pos => + simp only [← hX, σ₁.set_get, Bool.bnot_eq_to_not_eq] + apply hS _ h₀S + case neg => + simp only [σ₁.set_get_of_ne _ hX] + apply hSC + aesop + have ⟨x, τ, hMem, H⟩ := go h₁' h₂ s' hS' hSC' hCard' + refine ⟨x, τ, h' ▸ Finset.mem_insert_of_mem hMem, H⟩ + +end PropForm + +namespace PropTerm + +variable [DecidableEq ν] + +/-- See `semVars`. -/ +private def semVars' (φ : PropTerm ν) : Set ν := + { x | ∃ (τ : PropAssignment ν), τ ⊨ φ ∧ τ.set x (!τ x) ⊭ φ } + +private theorem semVars'_subset_vars (φ : PropForm ν) : semVars' ⟦φ⟧ ⊆ φ.vars := + fun x ⟨_, hτ, hτ'⟩ => PropForm.mem_vars_of_flip x hτ hτ' + +private instance semVars'_finite (φ : PropTerm ν) : Set.Finite φ.semVars' := + have ⟨φ', h⟩ := Quotient.exists_rep φ + Set.Finite.subset (Finset.finite_toSet _) (h ▸ semVars'_subset_vars φ') + +/-- The *semantic variables* of `φ` are those it is sensitive to as a Boolean function. +Unlike `vars`, this set is stable under equivalence of formulas. -/ +noncomputable def semVars (φ : PropTerm ν) : Finset ν := + Set.Finite.toFinset φ.semVars'_finite + +theorem mem_semVars (φ : PropTerm ν) (x : ν) : + x ∈ φ.semVars ↔ ∃ (τ : PropAssignment ν), τ ⊨ φ ∧ τ.set x (!τ x) ⊭ φ := by + simp [Set.Finite.mem_toFinset, semVars, semVars'] + +/-- Any two assignments with opposing evaluations on `φ` disagree on a semantic variable of `φ`. -/ +theorem exists_semVar {φ : PropTerm ν} {σ₁ σ₂ : PropAssignment ν} : σ₁ ⊨ φ → σ₂ ⊭ φ → + ∃ (x : ν), σ₁ x ≠ σ₂ x ∧ x ∈ φ.semVars := by + have ⟨φ', hMk⟩ := Quotient.exists_rep φ + dsimp + rw [← hMk, satisfies_mk, satisfies_mk] + intro h₁ h₂ + have ⟨x, τ, hNe, hτ, hτ'⟩ := PropForm.exists_flip h₁ h₂ + use x, hNe + simp only [mem_semVars] + use τ + rw [satisfies_mk, satisfies_mk] + exact ⟨hτ, hτ'⟩ + +theorem agreeOn_semVars {φ : PropTerm ν} {σ₁ σ₂ : PropAssignment ν} : + σ₁.agreeOn φ.semVars σ₂ → (σ₁ ⊨ φ ↔ σ₂ ⊨ φ) := by + suffices ∀ {σ₁ σ₂}, σ₁.agreeOn φ.semVars σ₂ → σ₁ ⊨ φ → σ₂ ⊨ φ from + fun h => ⟨this h, this h.symm⟩ + intro σ₁ σ₂ h h₁ + by_contra h₂ + have ⟨x, hNe, hMem⟩ := exists_semVar h₁ h₂ + exact hNe (h x hMem) + +theorem eval_of_agreeOn_semVars {φ : PropTerm ν} {σ₁ σ₂ : PropAssignment ν} : + σ₁.agreeOn φ.semVars σ₂ → φ.eval σ₁ = φ.eval σ₂ := by + intro h + have := agreeOn_semVars h + dsimp only [SemanticEntails.entails, satisfies] at this + aesop + +@[simp] +theorem semVars_var (x : ν) : (var x).semVars = {x} := by + ext y + simp only [Finset.mem_singleton, mem_semVars, satisfies_var] + refine ⟨?mp, ?mpr⟩ + case mp => + intro ⟨τ, hτ, hτ'⟩ + by_contra h + have := τ.set_get_of_ne (!τ y) h + exact hτ' (hτ ▸ this) + case mpr => + intro h; cases h + use (fun _ => true) + simp + +@[simp] +theorem semVars_tr (ν) [DecidableEq ν] : (⊤ : PropTerm ν).semVars = ∅ := by + ext + simp [mem_semVars] + +@[simp] +theorem semVars_fls (ν) [DecidableEq ν] : (⊥ : PropTerm ν).semVars = ∅ := by + ext + simp [mem_semVars] + +@[simp] +theorem semVars_neg (φ : PropTerm ν) : φᶜ.semVars = φ.semVars := by + ext x + simp only [mem_semVars] + constructor <;> { + intro ⟨τ, hτ, hτ'⟩ + simp only [satisfies_neg, not_not] at hτ hτ' ⊢ + let τ' := τ.set x (!τ x) + have : (!τ' x) = τ x := by + simp only [τ.set_get x, Bool.not_not] + refine ⟨τ', hτ', ?_⟩ + rw [τ.set_set, this, τ.set_same] + exact hτ + } + +theorem semVars_conj (φ₁ φ₂ : PropTerm ν) : (φ₁ ⊓ φ₂).semVars ⊆ φ₁.semVars ∪ φ₂.semVars := by + intro x + simp only [Finset.mem_union, mem_semVars, satisfies_conj, not_and_or] + aesop + +theorem semVars_disj (φ₁ φ₂ : PropTerm ν) : (φ₁ ⊔ φ₂).semVars ⊆ φ₁.semVars ∪ φ₂.semVars := by + intro x + simp only [Finset.mem_union, mem_semVars] + aesop + +theorem semVars_impl (φ₁ φ₂ : PropTerm ν) : (φ₁ ⇨ φ₂).semVars ⊆ φ₁.semVars ∪ φ₂.semVars := by + rw [himp_eq] + have := semVars_disj (φ₁ᶜ) φ₂ + rw [sup_comm, semVars_neg] at this + exact this + +theorem semVars_biImpl (φ₁ φ₂ : PropTerm ν) : + (PropTerm.biImpl φ₁ φ₂).semVars ⊆ φ₁.semVars ∪ φ₂.semVars := by + rw [biImpl_eq_impls] + apply subset_trans (semVars_conj _ _) + apply Finset.union_subset + . apply semVars_impl + . rw [Finset.union_comm] + apply semVars_impl + +/-- Two functions φ₁ and φ₂ are equivalent over X when for every assignment τ, models of φ₁ +extending τ over X are in bijection with models of φ₂ extending τ over X. -/ +-- This is `sequiv` here: https://github.com/ccodel/verified-encodings/blob/master/src/cnf/encoding.lean +def equivalentOver (X : Set ν) (φ₁ φ₂ : PropTerm ν) := + ∀ τ, (∃ (σ₁ : PropAssignment ν), σ₁.agreeOn X τ ∧ σ₁ ⊨ φ₁) ↔ + (∃ (σ₂ : PropAssignment ν), σ₂.agreeOn X τ ∧ σ₂ ⊨ φ₂) + +-- NOTE: This is a better definition than `equivalentOver`. It would be nice to clean the proofs up +-- to use it, but it's not essential. +def extendsOver (X : Set ν) (φ₁ φ₂ : PropTerm ν) := + ∀ (σ₁ : PropAssignment ν), σ₁ ⊨ φ₁ → ∃ (σ₂ : PropAssignment ν), σ₂.agreeOn X σ₁ ∧ σ₂ ⊨ φ₂ + +theorem equivalentOver_iff_extendsOver (X : Set ν) (φ₁ φ₂ : PropTerm ν) : + equivalentOver X φ₁ φ₂ ↔ (extendsOver X φ₁ φ₂ ∧ extendsOver X φ₂ φ₁) := by + constructor + case mp => + intro h + exact ⟨fun σ₁ h₁ => h σ₁ |>.mp ⟨σ₁, σ₁.agreeOn_refl X, h₁⟩, + fun σ₂ h₂ => h σ₂ |>.mpr ⟨σ₂, σ₂.agreeOn_refl X, h₂⟩⟩ + case mpr => + intro ⟨h₁, h₂⟩ + intro τ + constructor + case mp => + intro ⟨σ₁, hAgree₁, hσ₁⟩ + have ⟨σ₂, hAgree₂, hσ₂⟩ := h₁ σ₁ hσ₁ + exact ⟨σ₂, hAgree₂.trans hAgree₁, hσ₂⟩ + case mpr => + intro ⟨σ₂, hAgree₂, hσ₂⟩ + have ⟨σ₁, hAgree₁, hσ₁⟩ := h₂ σ₂ hσ₂ + exact ⟨σ₁, hAgree₁.trans hAgree₂, hσ₁⟩ + +theorem equivalentOver_refl (φ : PropTerm ν) : equivalentOver X φ φ := + fun _ => ⟨id, id⟩ +theorem equivalentOver.symm : equivalentOver X φ₁ φ₂ → equivalentOver X φ₂ φ₁ := + fun e τ => (e τ).symm +theorem equivalentOver.trans : equivalentOver X φ₁ φ₂ → equivalentOver X φ₂ φ₃ → + equivalentOver X φ₁ φ₃ := + fun e₁ e₂ τ => (e₁ τ).trans (e₂ τ) + +theorem equivalentOver.subset {X Y : Set ν} : X ⊆ Y → equivalentOver Y φ₁ φ₂ → + equivalentOver X φ₁ φ₂ := by + intro hSub + suffices ∀ φ₁ φ₂ τ, equivalentOver Y φ₁ φ₂ → + (∃ (σ₁ : PropAssignment ν), σ₁.agreeOn X τ ∧ σ₁ ⊨ φ₁) → + ∃ (σ₂ : PropAssignment ν), σ₂.agreeOn X τ ∧ σ₂ ⊨ φ₂ from + fun e τ => ⟨this φ₁ φ₂ τ e, this φ₂ φ₁ τ e.symm⟩ + intro φ₁ φ₂ τ e ⟨σ₁, hA, hS⟩ + have ⟨σ₃, hA', hS'⟩ := (e σ₁).mp ⟨σ₁, σ₁.agreeOn_refl _, hS⟩ + exact ⟨σ₃, hA'.subset hSub |>.trans hA, hS'⟩ + +theorem equivalentOver_semVars {X : Set ν} : φ₁.semVars ⊆ X → φ₂.semVars ⊆ X → + equivalentOver X φ₁ φ₂ → φ₁ = φ₂ := by + suffices ∀ {φ₁ φ₂} {τ : PropAssignment ν}, φ₂.semVars ⊆ X → + equivalentOver X φ₁ φ₂ → τ ⊨ φ₁ → τ ⊨ φ₂ by + intro h₁ h₂ e + ext τ + exact ⟨this h₂ e, this h₁ e.symm⟩ + intro φ₁ φ₂ τ h₂ e h + have ⟨σ₁, hA, hS⟩ := (e τ).mp ⟨τ, τ.agreeOn_refl _, h⟩ + have : σ₁ ⊨ φ₂ ↔ τ ⊨ φ₂ := agreeOn_semVars (hA.subset h₂) + exact this.mp hS + +/-- A function has the unique extension property from `X` to `Y` (both sets of variables) when any +satisfying assignment, if it exists, is uniquely determined on `Y` by its values on `X`. Formally, +any two satisfying assignments which agree on `X` must also agree on `Y`. -/ +/- TODO: Model equivalence is expected to follow from this. For example: +equivalentOver φ₁.vars ⟦φ₁⟧ ⟦φ₂⟧ ∧ hasUniqueExtension ⟦φ₂⟧ φ₁.vars φ₂.vars → +{ σ : { x // x ∈ φ₁.vars} → Bool | σ ⊨ φ₁ } ≃ { σ : { x // x ∈ φ₂.vars } → Bool | σ ⊨ φ₂ } -/ +def hasUniqueExtension (X Y : Set ν) (φ : PropTerm ν) := + ∀ ⦃σ₁ σ₂ : PropAssignment ν⦄, σ₁ ⊨ φ → σ₂ ⊨ φ → σ₁.agreeOn X σ₂ → σ₁.agreeOn Y σ₂ + +theorem hasUniqueExtension_refl (X : Set ν) (φ : PropTerm ν) : hasUniqueExtension X X φ := + by simp [hasUniqueExtension] + +theorem hasUniqueExtension.subset_left : X ⊆ X' → hasUniqueExtension X Y φ → + hasUniqueExtension X' Y φ := + fun hSub h _ _ h₁ h₂ hAgree => h h₁ h₂ (hAgree.subset hSub) + +theorem hasUniqueExtension.subset_right : Y' ⊆ Y → hasUniqueExtension X Y φ → + hasUniqueExtension X Y' φ := + fun hSub h _ _ h₁ h₂ hAgree => (h h₁ h₂ hAgree).subset hSub + +theorem hasUniqueExtension.trans : hasUniqueExtension X Y φ → hasUniqueExtension Y Z φ → + hasUniqueExtension X Z φ := + fun hXY hYZ _ _ h₁ h₂ hAgree => hAgree |> hXY h₁ h₂ |> hYZ h₁ h₂ + +theorem hasUniqueExtension.conj_right (ψ : PropTerm ν) : + hasUniqueExtension X Y φ → hasUniqueExtension X Y (φ ⊓ ψ) := + fun hXY _ _ h₁ h₂ hAgree => hXY (satisfies_conj.mp h₁).left (satisfies_conj.mp h₂).left hAgree + +theorem hasUniqueExtension.conj_left (ψ : PropTerm ν) : + hasUniqueExtension X Y φ → hasUniqueExtension X Y (ψ ⊓ φ) := + fun hXY _ _ h₁ h₂ hAgree => hXY (satisfies_conj.mp h₁).right (satisfies_conj.mp h₂).right hAgree + +theorem hasUniqueExtension_to_empty (X : Set ν) (φ : PropTerm ν) : hasUniqueExtension X ∅ φ := + hasUniqueExtension_refl X φ |>.subset_right (Set.empty_subset X) + +end PropTerm + +namespace PropForm + +variable [DecidableEq ν] + +theorem equivalentOver_of_equivalent : equivalent φ₁ φ₂ → PropTerm.equivalentOver X ⟦φ₁⟧ ⟦φ₂⟧ := + fun h => Quotient.sound h ▸ PropTerm.equivalentOver_refl ⟦φ₁⟧ + +theorem semVars_eq_of_equivalent (φ₁ φ₂ : PropForm ν) : equivalent φ₁ φ₂ → + PropTerm.semVars ⟦φ₁⟧ = PropTerm.semVars ⟦φ₂⟧ := + fun h => Quotient.sound h ▸ rfl + +theorem semVars_subset_vars (φ : PropForm ν) : PropTerm.semVars ⟦φ⟧ ⊆ φ.vars := by + simp only [PropTerm.semVars, Set.Finite.toFinset_subset] + exact PropTerm.semVars'_subset_vars φ + +theorem equivalentOver_vars {X : Set ν} : φ₁.vars ⊆ X → φ₂.vars ⊆ X → + PropTerm.equivalentOver X ⟦φ₁⟧ ⟦φ₂⟧ → equivalent φ₁ φ₂ := + fun h₁ h₂ h => Quotient.exact + (PropTerm.equivalentOver_semVars + (subset_trans (semVars_subset_vars φ₁) h₁) + (subset_trans (semVars_subset_vars φ₂) h₂) + h) + +end PropForm \ No newline at end of file diff --git a/Experiments/CPOG/Model/ToMathlib.lean b/Experiments/CPOG/Model/ToMathlib.lean new file mode 100644 index 0000000..f9d3fe7 --- /dev/null +++ b/Experiments/CPOG/Model/ToMathlib.lean @@ -0,0 +1,309 @@ +/- +Copyright (c) 2023 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +import Std.Classes.BEq + +import Mathlib.Tactic.Linarith +import Mathlib.Data.List.Lemmas +import Mathlib.Data.List.Perm + +/-! Std.Logic or Std.Bool? -/ + +@[simp] theorem Bool.bnot_eq_to_not_eq (a b : Bool) : + ((!a) = b) = ¬(a = b) := by cases a <;> cases b <;> decide +@[simp] theorem Bool.eq_bnot_to_not_eq (a b : Bool) : + (a = (!b)) = ¬(a = b) := by cases a <;> cases b <;> decide +@[simp] theorem Bool.eq_true_iff_eq_true_to_eq (a b : Bool) : + (a = true ↔ b = true) = (a = b) := by cases a <;> cases b <;> decide +@[simp] theorem Bool.eq_false_iff_eq_false_to_eq (a b : Bool) : + (a = false ↔ b = false) = (a = b) := by cases a <;> cases b <;> decide + +/-! Std.Logic -/ + +theorem Bool.not_eq_true_iff_ne_true {b : Bool} : (!b) = true ↔ ¬(b = true) := by + cases b <;> decide + +theorem Bool.bne_iff_not_beq [BEq α] {a a' : α} : a != a' ↔ ¬(a == a') := + Bool.not_eq_true_iff_ne_true + +theorem Bool.beq_or_bne [BEq α] (a a' : α) : a == a' ∨ a != a' := + by + cases h : a == a' + . apply Or.inr + simp [bne_iff_not_beq, h] + . exact Or.inl rfl + +@[simp] +theorem Bool.bne_eq_false [BEq α] {a a' : α} : (a != a') = false ↔ a == a' := by + dsimp [bne] + cases (a == a') <;> simp + +/-! Std.Classes.BEq -/ + +instance [BEq α] [LawfulBEq α] : PartialEquivBEq α where + symm h := by cases (beq_iff_eq _ _).mp h; exact h + trans h₁ h₂ := by cases (beq_iff_eq _ _).mp h₁; cases (beq_iff_eq _ _).mp h₂; exact h₁ + +theorem bne_symm [BEq α] [PartialEquivBEq α] {a b : α} : a != b → b != a := + fun h => Bool.not_eq_true_iff_ne_true.mpr fun h' => + Bool.bne_iff_not_beq.mp h (PartialEquivBEq.symm h') + +@[simp] +theorem bne_iff_ne [BEq α] [LawfulBEq α] (a b : α) : a != b ↔ a ≠ b := by + simp [Bool.bne_iff_not_beq] + +/-! Maybe Std.Notation -/ + +/-- Notation typeclass for semantic entailment `⊨`. -/ +class SemanticEntails (α : Type u) (β : outParam $ Type v) where + entails : α → β → Prop + +infix:51 " ⊨ " => SemanticEntails.entails +infix:51 " ⊭ " => fun M φ => ¬(M ⊨ φ) + +/-! Data.List.Extra or something -/ + +@[specialize] +def List.foldlDep {α : Type u} {β : Type v} : (l : List β) → (f : α → (b : β) → b ∈ l → α) → + (init : α) → α + | nil, _, init => init + | cons b l, f, init => foldlDep l (fun a b h => f a b (.tail _ h)) (f init b (.head l)) + +@[specialize] +def List.mapDep {α : Type u} {β : Type v} : (l : List α) → (f : (a : α) → a ∈ l → β) → List β + | nil, _ => [] + | cons a l, f => f a (.head l) :: mapDep l fun a h => f a (.tail _ h) + +@[simp] +theorem List.map_mapDep {γ : Type u} : (l : List α) → (f : (a : α) → a ∈ l → β) → (g : β → γ) → + (l.mapDep f).map g = l.mapDep (fun a h => g (f a h)) + | nil, _, _ => rfl + | cons a l, f, g => by + -- https://www.youtube.com/watch?v=Hd2JgADY9d8 + simp [map, mapDep, map_mapDep] + +/-! Data.List.Lemmas -/ + +namespace List + +/-! drop -/ + +theorem drop_eq_cons_get (l : List α) (i : Nat) (h : i < l.length) + : l.drop i = l.get ⟨i, h⟩ :: l.drop (i + 1) := + go i l h +where go : (i : Nat) → (l : List α) → (h : i < l.length) → l.drop i = l[i] :: l.drop (i + 1) + | 0, _::_, _ => by simp + | n+1, _::as, h => by + have : n < length as := Nat.lt_of_succ_lt_succ h + have ih := go n as this + simp [ih] + +theorem drop_ext (l₁ l₂ : List α) (j : Nat) + : (∀ i ≥ j, l₁.get? i = l₂.get? i) → l₁.drop j = l₂.drop j := by + intro H + apply ext fun k => ?_ + rw [get?_drop, get?_drop] + apply H _ (Nat.le_add_right _ _) + +/-! find? -/ + +theorem find?_filter (l : List α) (p q : α → Bool) (h : ∀ a, p a → q a) : + (l.filter q).find? p = l.find? p := by + induction l with + | nil => rfl + | cons x xs ih => + dsimp [filter] + split <;> split <;> simp [*] at * + +theorem find?_filter' (l : List α) (p q : α → Bool) (h : ∀ a, p a → !q a) : + (l.filter q).find? p = none := by + induction l with + | nil => rfl + | cons x xs ih => + dsimp [filter] + split + next _ hQ => rw [find?_cons_of_neg _ (fun hP => by aesop), ih] + next => exact ih + +-- theorem find?_eraseP (l : List α) (p q : α → Bool) (h : ∀ a, p a → !q a) : +-- (l.eraseP q).find? p = l.find? p := by +-- induction l with +-- | nil => rfl +-- | cons x xs ih => +-- dsimp [filter, eraseP] +-- split +-- next _ hP => aesop +-- next _ hP => +-- cases (q x : Bool) with -- `split_ifs` doesn't work on `bif` +-- | false => rw [cond_false, find?_cons_of_neg _ (by simp [hP]), ih] +-- | true => rw [cond_true] + +/-! foldl -/ + +theorem foldl_cons_fn (l₁ l₂ : List α) : + l₁.foldl (init := l₂) (fun acc x => x :: acc) = l₁.reverse ++ l₂ := by + induction l₁ generalizing l₂ <;> simp [*] + +theorem foldl_append_fn (l₁ : List α) (l₂ : List β) (f : α → List β) : + l₁.foldl (init := l₂) (fun acc x => acc ++ f x) = l₂ ++ l₁.bind f := by + induction l₁ generalizing l₂ <;> simp [*] + +end List + +/-! Data.Array.Lemmas -/ + +theorem Array.get_of_mem_data {as : Array α} {a : α} : a ∈ as.data → ∃ (i : Fin as.size), as[i] = a := + List.get_of_mem + +theorem Array.get_mem_data (as : Array α) (i : Fin as.size) : as[i] ∈ as.data := by + simp [getElem_mem_data] + +/-! Data.List.Perm -/ + +namespace List + +/-- The way Lean 4 computes the motive with `elab_as_elim` has changed +relative to the behaviour of `elab_as_eliminator` in Lean 3. +See +https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Potential.20elaboration.20bug.20with.20.60elabAsElim.60/near/299573172 +for an explanation of the change made here relative to mathlib3. +-/ +@[elab_as_elim] +theorem perm_induction_on' + {P : (l₁ : List α) → (l₂ : List α) → l₁ ~ l₂ → Prop} {l₁ l₂ : List α} (p : l₁ ~ l₂) + (nil : P [] [] .nil) + (cons : ∀ x l₁ l₂, (h : l₁ ~ l₂) → P l₁ l₂ h → P (x :: l₁) (x :: l₂) (.cons x h)) + (swap : ∀ x y l₁ l₂, (h : l₁ ~ l₂) → P l₁ l₂ h → + P (y :: x :: l₁) (x :: y :: l₂) (.trans (.swap x y _) (.cons _ (.cons _ h)))) + (trans : ∀ l₁ l₂ l₃, (h₁ : l₁ ~ l₂) → (h₂ : l₂ ~ l₃) → P l₁ l₂ h₁ → P l₂ l₃ h₂ → + P l₁ l₃ (.trans h₁ h₂)) : P l₁ l₂ p := + have P_refl l : P l l (.refl l) := + List.recOn l nil fun x xs ih ↦ cons x xs xs (Perm.refl xs) ih + Perm.recOn p nil cons (fun x y l ↦ swap x y l l (Perm.refl l) (P_refl l)) @trans + +end List + +/-! Maybe Data.List.Unique -/ + +namespace List + +/-- There is at most one element satisfying `p` in `l`. -/ +-- TODO Move the other `of_unique` lemmas to this formulation +-- and move `pairwise'` lemmas below to `unique` +def unique (p : α → Prop) (l : List α) : Prop := + l.Pairwise (p · → ¬p ·) + +def unique_cons_of_true {x : α} {l : List α} {p : α → Prop} : + (x :: l).unique p → p x → ∀ y ∈ l, ¬p y := + fun h hP _ hY => rel_of_pairwise_cons h hY hP + +theorem unique.sublist {l₁ l₂ : List α} {p : α → Prop} : l₁ <+ l₂ → l₂.unique p → l₁.unique p := + Pairwise.sublist + +example {x y : α} {p : α → Prop} : (p x → ¬p y) → (p y → ¬p x) := + fun h hY hX => h hX hY + +def unique.perm {l₁ l₂ : List α} {p : α → Prop} : l₁ ~ l₂ → l₁.unique p → l₂.unique p := + fun h h₁ => h.pairwise h₁ fun _ _ H hB hA => H hA hB + +theorem find?_eq_of_perm_of_unique {l₁ l₂ : List α} {p : α → Bool} : + l₁ ~ l₂ → l₁.unique (p ·) → l₁.find? p = l₂.find? p := by + intro h hUniq + induction h using perm_induction_on' with + | nil => rfl + | cons x l₁ _ _ ih => + have := ih (hUniq.sublist (sublist_cons x l₁)) + simp [find?, this] + | swap x y l₁ l₂ _ ih => + dsimp [find?] + split <;> split <;> try rfl + next hY _ hX => + have : ¬p x := unique_cons_of_true hUniq hY x (mem_cons_self _ _) + contradiction + next => exact ih <| hUniq.sublist <| sublist_of_cons_sublist <| sublist_cons y (x :: l₁) + | trans l₁ l₂ l₃ h₁₂ _ h₁ h₂ => + simp [h₁ hUniq, h₂ (hUniq.perm h₁₂)] + +/-- If there is at most one element with the property `p`, finding that one element is the same +as finding any. -/ +theorem find?_eq_some_of_unique {l : List α} {a : α} {p : α → Bool} + : l.Pairwise (p · → !p ·) → (l.find? p = some a ↔ (a ∈ l ∧ p a)) := by + refine fun h => ⟨fun h' => ⟨find?_mem h', find?_some h'⟩, ?_⟩ + induction l with + | nil => simp + | cons x xs ih => + intro ⟨hMem, hP⟩ + cases mem_cons.mp hMem with + | inl hX => simp [find?, ← hX, hP] + | inr hXs => + unfold find? + cases hPX : (p x) with + | false => + apply ih (Pairwise.sublist (sublist_cons x xs) h) ⟨hXs, hP⟩ + | true => + cases hP ▸ (pairwise_cons.mp h |>.left a hXs hPX) + +/-- If there is at most one element with the property `p`, erasing one such element is the same +as filtering out all of them. -/ +theorem eraseP_eq_filter_of_unique (l : List α) (p : α → Bool) + : l.Pairwise (p · → !p ·) → l.eraseP p = l.filter (!p ·) := by + intro h + induction l with + | nil => rfl + | cons x xs ih => + specialize ih (Pairwise.sublist (sublist_cons x xs) h) + cases hP : p x with + | true => + rw [pairwise_cons] at h + have : ∀ a ∈ xs, !p a := fun a hA => h.left a hA hP + simp [eraseP, filter, hP, filter_eq_self.mpr this] + | false => simp [eraseP_cons, filter, hP, ih] + +theorem replaceF_of_unique {a b : α} {l : List α} (f : α → Option α) : + a ∈ l → f a = some b → l.Pairwise (fun a₁ a₂ => (f a₁).isSome → ¬(f a₂).isSome) → + l.replaceF f ~ b :: l.eraseP (f · |>.isSome) := by + intro hMem hF hPws + induction l with + | nil => cases hMem + | cons x xs ih => + unfold replaceF eraseP + cases mem_cons.mp hMem with + | inl hMem => simp [← hMem, hF, Perm.refl] + | inr hMem => + have : f x = none := by + have .cons hPws _ := hPws + exact Option.eq_none_iff_forall_not_mem.mpr fun b hB' => + hPws a hMem (hB' ▸ rfl) (hF ▸ rfl) + simp only [this, Option.isSome_none, cond_false] + have := ih hMem (hPws.sublist <| sublist_cons _ _) + exact .trans (.cons x this) (.swap b x _) + +end List + +/-! Int -/ + +theorem Int.eq_zero_of_lt_neg_iff_lt (i : Int) : (0 < -i ↔ 0 < i) → i = 0 := by + intro h + by_cases hLt : 0 < i + . have := h.mpr hLt; linarith + . have : ¬ 0 < -i := fun h₂ => hLt (h.mp h₂); linarith + +/-! Loop -/ + +def loopM_with_invariant [Monad m] {State : Type _} (n : Nat) + (invariant : Nat → State → Prop) + (start_state : { st // invariant 0 st }) + (step : (i : Fin n) → { st // invariant i st } → m { st // invariant (i+1) st }) : + m { st // invariant n st } := + go n 0 (by rw [add_zero]) start_state +where + go : (b : Nat) → (i : Nat) → b + i = n → { st // invariant i st } → m { st // invariant n st } + | 0, i, h, state => + have : i = n := Nat.zero_add i ▸ h + return this ▸ state + | (b + 1), i, h, state => do + let v ← step ⟨i, by rw [← h]; linarith⟩ state + go b (i + 1) (by rw [← h]; ac_rfl) v \ No newline at end of file From 6017f6a436e5117364a434605b7b39fd92ab9192 Mon Sep 17 00:00:00 2001 From: James Date: Wed, 17 Apr 2024 05:51:35 -0400 Subject: [PATCH 2/2] it compiles! (with some sorries) --- Experiments/CPOG/Checker/CheckerCore.lean | 32 +++++++-------- Experiments/CPOG/Checker/Parse.lean | 12 +++--- Experiments/CPOG/Count/Pog.lean | 14 +++---- Experiments/CPOG/Count/PropForm.lean | 47 ++++++++++++----------- Experiments/CPOG/Data/ClauseDb.lean | 22 +++++------ Experiments/CPOG/Data/HashMap/Basic.lean | 5 ++- Experiments/CPOG/Data/HashMap/Lemmas.lean | 21 +++++----- Experiments/CPOG/Data/HashMap/WF.lean | 20 +++++----- Experiments/CPOG/Data/HashSet.lean | 4 +- Experiments/CPOG/Data/ICnf.lean | 44 ++++++++++----------- Experiments/CPOG/Data/Pog.lean | 16 ++++---- Experiments/CPOG/Main.lean | 4 +- Experiments/CPOG/Model/Cpog.lean | 24 ++++++------ Experiments/CPOG/Model/Extensions.lean | 10 ++--- Experiments/CPOG/Model/PropForm.lean | 4 +- Experiments/CPOG/Model/PropTerm.lean | 19 ++++----- Experiments/CPOG/Model/PropVars.lean | 14 ++++--- Experiments/CPOG/Model/ToMathlib.lean | 10 ++--- Experiments/CPOG/README.md | 5 +++ lakefile.lean | 8 ++++ 20 files changed, 176 insertions(+), 159 deletions(-) create mode 100644 Experiments/CPOG/README.md diff --git a/Experiments/CPOG/Checker/CheckerCore.lean b/Experiments/CPOG/Checker/CheckerCore.lean index 8d0baaf..47721be 100644 --- a/Experiments/CPOG/Checker/CheckerCore.lean +++ b/Experiments/CPOG/Checker/CheckerCore.lean @@ -6,11 +6,11 @@ Authors: Wojciech Nawrocki import Std.Data.Array.Basic -import ProofChecker.Data.ClauseDb -import ProofChecker.Data.Pog -import ProofChecker.Count.Pog -import ProofChecker.Data.HashSet -import ProofChecker.Model.Cpog +import Experiments.CPOG.Data.ClauseDb +import Experiments.CPOG.Data.Pog +import Experiments.CPOG.Count.Pog +import Experiments.CPOG.Data.HashSet +import Experiments.CPOG.Model.Cpog /-- An index into the `ClauseDb`. -/ abbrev ClauseIdx := Nat @@ -311,7 +311,7 @@ def initialDepVars (inputCnf : ICnf) : { dv : HashMap Var (HashSet Var) // { y | dv.contains y } = inputCnf.vars.toFinset ∧ ∀ x D, dv.find? x = some D → x ∈ D.toFinset } := let dv := initialCnfVars .empty inputCnf - have allVars_eq := by ext; simp [initialCnfVars₁] + have allVars_eq := by ext; simp [initialCnfVars₁, dv] have of_find := by apply initialCnfVars₂; simp ⟨dv, allVars_eq, of_find⟩ @@ -503,7 +503,7 @@ def getDepsArray {st : PreState} (pfs : st.WF) (ls : Array ILit) : (p := fun i val => (st.pog.toPropForm ls[i]).vars ⊆ val.toFinset) (h0 := by simp) (hs := by - dsimp + dsimp [f, x] intro i ih split next h => @@ -542,7 +542,7 @@ def addPogDefClause (db₀ : ClauseDb ClauseIdx) (pd₀ : HashSet ClauseIdx) let ⟨db, hAdd, hNContains, hDb⟩ ← addClause db₀ idx C let pd := pd₀.insert idx - have hMem : idx ∈ pd.toFinset := by simp + have hMem : idx ∈ pd.toFinset := by simp [pd] have hContainsTrans : ∀ {idx}, db₀.contains idx → db.contains idx := fun h => by rw [hAdd] exact db₀.contains_addClause _ _ _ |>.mpr (Or.inl h) @@ -550,9 +550,9 @@ def addPogDefClause (db₀ : ClauseDb ClauseIdx) (pd₀ : HashSet ClauseIdx) rw [hAdd] exact db₀.contains_addClause _ _ _ |>.mpr (Or.inr rfl) have hHelper : db₀.toPropTermSub (· ∈ pd.toFinset) = db₀.toPropTermSub (· ∈ pd₀.toFinset) := by - apply db₀.toPropTermSub_subset_eq fun _ hMem => by simp; exact Or.inr hMem + apply db₀.toPropTermSub_subset_eq fun _ hMem => by simp [pd]; exact Or.inr hMem intro idx hMem hContains - simp at hMem + simp [pd] at hMem cases hMem with | inl h => exfalso @@ -563,7 +563,7 @@ def addPogDefClause (db₀ : ClauseDb ClauseIdx) (pd₀ : HashSet ClauseIdx) rw [← hHelper, hAdd] exact db₀.toPropTermSub_addClause_eq _ hMem hNContains have hPdDb : ∀ idx, idx ∈ pd.toFinset → db.contains idx := by - simp only [HashSet.toFinset_insert, Finset.mem_singleton, Finset.mem_insert] + simp only [pd, HashSet.toFinset_insert, Finset.mem_singleton, Finset.mem_insert] intro _ h cases h with | inl h => exact h ▸ hContains @@ -670,7 +670,7 @@ def addPogDefClauses (db₀ : ClauseDb ClauseIdx) (pd₀ : HashSet ClauseIdx) have ⟨l, hL, hφ⟩ := h exact hφ ▸ h₁ l hL | inr h => - simp_all + sorry -- simp_all have hDb' := by rw [hDb, ih₁, inf_assoc, hEquiv] have hPd' := by rw [hPd, ih₂, inf_assoc, hEquiv] return ⟨st', hDb', hPd', h⟩) @@ -712,7 +712,7 @@ def addProdClauses (db₀ : ClauseDb ClauseIdx) (pd₀ : HashSet ClauseIdx) intro refine ⟨?_, fun l hL => IClause.satisfies_iff.mpr ?_⟩ <;> cases h : τ x <;> - aesop + sorry -- aesop have hDb := by rw [hDb₂, hDb₁, inf_assoc, hEquiv] have hPd := by @@ -908,8 +908,8 @@ def ensurePogHints (st : PreState) (hints : Array ClauseIdx) : match hSz : hints.size with | 0 => return ⟨(), fun _ hMem => by - dsimp [Array.size] at hSz - rw [List.length_eq_zero.mp hSz] at hMem + rw [Array.size_eq_length_data, List.length_eq_zero] at hSz + rw [hSz] at hMem contradiction⟩ | i+1 => let ⟨_, h⟩ ← go i (hSz ▸ Nat.lt_succ_self _) (fun j hLt => by @@ -1207,4 +1207,4 @@ macro_rules | `(log! $interpStr) => `(log_ fun _ => s!$interpStr) end CheckerState --/ \ No newline at end of file +-/ diff --git a/Experiments/CPOG/Checker/Parse.lean b/Experiments/CPOG/Checker/Parse.lean index 7a80783..e2951c6 100644 --- a/Experiments/CPOG/Checker/Parse.lean +++ b/Experiments/CPOG/Checker/Parse.lean @@ -4,8 +4,8 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Wojciech Nawrocki -/ -import ProofChecker.Data.ICnf -import ProofChecker.Checker.CheckerCore +import Experiments.CPOG.Data.ICnf +import Experiments.CPOG.Checker.CheckerCore def Except.ofOption (e : ε) : Option α → Except ε α | none => .error e @@ -87,7 +87,7 @@ def IClause.ofTokensBounded (bd : Nat) (tks : Array Token) : Except String IClau /-- Return a CNF computed from the tokens of a DIMACS CNF file, together with the variable count stored in the header. -/ def ICnf.ofLines (lns : Array (Array Token)) : Except String (ICnf × Nat) := do - let some hdr := lns[0]? + let some hdr := lns[0]? | throw s!"expected at least one line" let #[.str "p", .str "cnf", nVars, .int nClauses] := hdr | throw s!"unexpected header {hdr}" @@ -112,7 +112,7 @@ def ICnf.readDimacsFile (fname : String) : IO (ICnf × Nat) := do match ofLines lns with | .ok v => return v | .error e => throw <| IO.userError e - + def ICnf.toDimacs (cnf : ICnf) (nVars : Nat) : String := Id.run do let mut s := s!"p cnf {nVars} {cnf.size}\n" for C in cnf do @@ -120,7 +120,7 @@ def ICnf.toDimacs (cnf : ICnf) (nVars : Nat) : String := Id.run do s := s ++ toString l ++ " " s := s ++ "0\n" return s - + /-- Return a proof step given a DIMACS line. -/ def CpogStep.ofTokens (tks : Array Token) : Except String CpogStep := do let toUpHints (tks : Array Token) : Except String (Array Nat) := do @@ -174,4 +174,4 @@ def CpogStep.readDimacsFile (fname : String) : IO (Array CpogStep) := do | .ok v => pf := pf.push v | .error e => throw <| IO.userError s!"error on line '{" ".intercalate <| ln.toList.map toString}': {e}" - return pf \ No newline at end of file + return pf diff --git a/Experiments/CPOG/Count/Pog.lean b/Experiments/CPOG/Count/Pog.lean index 1398209..85cb7f3 100644 --- a/Experiments/CPOG/Count/Pog.lean +++ b/Experiments/CPOG/Count/Pog.lean @@ -4,8 +4,8 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Jeremy Avigad -/ -import ProofChecker.Data.Pog -import ProofChecker.Count.PropForm +import Experiments.CPOG.Data.Pog +import Experiments.CPOG.Count.PropForm open Nat open PogElt @@ -27,7 +27,7 @@ def conjProd' (nVars : Nat) {n : Nat} (g : Fin n → Nat) : Nat := theorem conjProd_eq_conjProd' : conjProd = conjProd' := by ext nVars n f - rw [conjProd, conjProd', Array.foldr_eq_foldr_data, List.ofFn, Array.toList_eq] + rw [conjProd, conjProd', Array.foldr_eq_foldr_data, List.ofFn] def toCountArray (pog : Pog) (nVars : Nat) : { A : Array Nat // A.size = pog.elts.size } := @@ -143,11 +143,10 @@ where rw [conjProd_eq_conjProd', conjProd', PropForm.arrayConj, PropForm.listConj, countModels_foldr_conj] apply congr_arg - rw [←Array.toList_eq, ←List.ofFn, List.map_ofFn] + rw [←List.ofFn, List.map_ofFn] apply congr_arg ext j simp only [Function.comp_apply] - simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt] have harg : PNat.natPred (ILit.var args[j]) < A.size := by dsimp at hinv; rw [hinv, PNat.natPred_lt_natPred] exact hwf j @@ -191,7 +190,7 @@ def conjProdW' {n : Nat} (g : Fin n → R) : R := theorem conjProdW_eq_conjProdW' : @conjProdW R _ = @conjProdW' R _ := by apply funext; intro n apply funext; intro g - rw [conjProdW, conjProdW', Array.foldr_eq_foldr_data, List.ofFn, Array.toList_eq] + rw [conjProdW, conjProdW', Array.foldr_eq_foldr_data, List.ofFn] def toRingEvalArray (pog : Pog) (weight : Var → R) : { A : Array R // A.size = pog.elts.size } := @@ -307,11 +306,10 @@ where rw [conjProdW_eq_conjProdW', conjProdW', PropForm.arrayConj, PropForm.listConj, ringEval_foldr_conj] apply congr_arg - rw [←Array.toList_eq, ←List.ofFn, List.map_ofFn] + rw [←List.ofFn, List.map_ofFn] apply congr_arg apply funext; intro j simp only [Function.comp_apply] - simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt] have harg : PNat.natPred (ILit.var args[j]) < A.size := by dsimp at hinv; rw [hinv, PNat.natPred_lt_natPred] exact hwf j diff --git a/Experiments/CPOG/Count/PropForm.lean b/Experiments/CPOG/Count/PropForm.lean index 1f6a86b..eb15ac8 100644 --- a/Experiments/CPOG/Count/PropForm.lean +++ b/Experiments/CPOG/Count/PropForm.lean @@ -7,7 +7,7 @@ Authors: Jeremy Avigad import Mathlib.Data.Finset.Powerset import Mathlib.Data.Finset.Card import Mathlib.Algebra.BigOperators.Ring -import ProofChecker.Data.Pog +import Experiments.CPOG.Data.Pog open Finset @@ -225,23 +225,24 @@ theorem models_neg_Disjoint (φ : PropForm ν) (s : Finset ν) : theorem models_conj {φ ψ: PropForm ν} (hdisj : φ.vars ∩ ψ.vars = ∅) : (φ.conj ψ).models ((φ.conj ψ).vars) = - ((φ.models φ.vars).product (ψ.models ψ.vars)).image (PropAssignment.cond φ.vars) := by + ((φ.models φ.vars) ×ˢ (ψ.models ψ.vars)).image (PropAssignment.cond φ.vars) := by symm; ext v - simp only [mem_image, mem_product, mem_models, Prod.exists, eval, Bool.and_eq_true, - PropAssignment.cond, vars] + simp only [mem_image, mem_product, mem_models, Prod.exists, vars, eval, Bool.and_eq_true] constructor . rintro ⟨v1, v2, ⟨⟨_, heval1⟩, ⟨hdef2, heval2⟩⟩, rfl⟩ constructor . intro x hx rw [mem_union, not_or] at hx - dsimp; rw [if_neg hx.1, hdef2 hx.2] + simp only [PropAssignment.cond] + rw [if_neg hx.1, hdef2 hx.2] . constructor . rw [←heval1]; apply eval_ext - intro x hx; rw [if_pos hx] + intro x hx; simp only [PropAssignment.cond]; rw [if_pos hx] . rw [←heval2]; apply eval_ext intro x hx simp only [eq_empty_iff_forall_not_mem, mem_inter, not_and'] at hdisj have hx' : x ∉ φ.vars := hdisj _ hx + simp only [PropAssignment.cond] rw [if_neg hx'] . intro ⟨hdef, heval1, heval2⟩ use fun x => if x ∈ φ.vars then v x else false @@ -259,13 +260,14 @@ theorem models_conj {φ ψ: PropForm ν} (hdisj : φ.vars ∩ ψ.vars = ∅) : apply eval_ext; intro x hx; rw [if_pos hx] . ext x have := @hdef x + simp only [PropAssignment.cond] split <;> simp_all theorem InjOn_cond (φ ψ : PropForm ν) {s t : Finset ν} (hdisj : s ∩ t = ∅) : - Set.InjOn (PropAssignment.cond s) <| (φ.models s).product (ψ.models t) := by + Set.InjOn (PropAssignment.cond s) <| ↑((φ.models s) ×ˢ (ψ.models t)) := by intro ⟨p11, p12⟩ hp1 ⟨p21, p22⟩ hp2 simp only [coe_product, Set.mem_prod, mem_coe, mem_models] at hp1 hp2 - simp only [PropAssignment.cond] + unfold PropAssignment.cond dsimp; intro h rw [Prod.mk.injEq] constructor @@ -360,18 +362,19 @@ theorem card_models_vars {φ : PropForm ν} {s : Finset ν} (h : φ.vars ⊆ s) card (φ.models s) = card (φ.models φ.vars) * 2^(card s - card φ.vars) := by let f (p : PropAssignment ν × Finset ν) : PropAssignment ν := fun x => if x ∈ φ.vars then p.1 x else p.2.toPropAssignment x - have h1 : ((φ.models φ.vars).product (s \ φ.vars).powerset).image f = φ.models s := by + have h1 : ((φ.models φ.vars) ×ˢ (s \ φ.vars).powerset).image f = φ.models s := by ext v; simp only [mem_image, mem_product, mem_models, mem_powerset, Prod.exists] constructor { rintro ⟨v, t, ⟨⟨_, hevalv⟩, hh⟩, rfl⟩ constructor . intro x hxns have : x ∉ φ.vars := fun h' => hxns (h h') - dsimp; rw [if_neg this, toPropAssignment_eq_false] + dsimp [f]; rw [if_neg this, toPropAssignment_eq_false] intro h'; apply hxns; exact subset_sdiff.mp hh |>.1 h' . rw [←hevalv] apply eval_ext intro x hx + dsimp [f] rw [if_pos hx] } intro ⟨hvdef, hevalv⟩ use v.restrict φ.vars, (s \ φ.vars).filter (fun x => v x) @@ -381,34 +384,33 @@ theorem card_models_vars {φ : PropForm ν} {s : Finset ν} (h : φ.vars ⊆ s) . simp . rw [eval_restrict_vars, hevalv] . apply filter_subset - . ext x; dsimp; split + . ext x; dsimp [f]; split . next h => rw [v.restrict_pos h] . next hmem => unfold Finset.toPropAssignment by_cases hxs : x ∈ s <;> split <;> simp_all [@hvdef x] - have h2 : Set.InjOn f <| (φ.models φ.vars).product (s \ φ.vars).powerset := by + have h2 : Set.InjOn f <| ↑((φ.models φ.vars) ×ˢ (s \ φ.vars).powerset) := by intro ⟨v1, t1⟩ h21 ⟨v2, t2⟩ h22 h23 simp only [Set.mem_prod, mem_product, mem_coe, mem_models, Set.mem_preimage, mem_powerset, - and_imp, subset_sdiff, Prod.forall, Prod.mk.injEq] at h21 h22 h23 |- + and_imp, subset_sdiff, Prod.forall, Prod.mk.injEq] at h21 h22 h23 ⊢ constructor . ext x by_cases hx : x ∈ φ.vars . have := congr_fun h23 x - simp [hx] at this; exact this + simp [hx, f] at this; exact this . rw [h21.1.1 hx, h22.1.1 hx] . ext x - simp at h21 by_cases hx : x ∈ φ.vars . rw [eq_false (disjoint_right.mp h21.2.2 hx), eq_false (disjoint_right.mp h22.2.2 hx)] . have := congr_fun h23 x - simp [hx] at this + simp [hx, f] at this rw [←toPropAssignment_eq_true, this, toPropAssignment_eq_true] rw [←h1, card_image_of_injOn h2, card_product, card_powerset, card_sdiff h] theorem card_models_conj_aux {φ ψ: PropForm ν} (hdisj : φ.vars ∩ ψ.vars = ∅) : card ((φ.conj ψ).models (φ.conj ψ).vars) = card (φ.models φ.vars) * card (ψ.models ψ.vars) := by - rw [models_conj hdisj, card_image_of_injOn (InjOn_cond _ _ hdisj), card_product] + rw [models_conj hdisj, card_image_of_injOn (InjOn_cond φ ψ hdisj), card_product] @[simp] theorem card_models_conj {φ ψ : PropForm ν} {s : Finset ν} (hsub : φ.vars ∪ ψ.vars ⊆ s) (hdisj : vars φ ∩ vars ψ = ∅) : @@ -493,7 +495,7 @@ theorem weightSum_insert (weight : ν → R) {φ : PropForm ν} {a : ν} {s : Fi rw [Finset.sum_image (injective_models_set h'), ←Finset.sum_add_distrib] apply Finset.sum_congr rfl intro τ hτ; rw [mem_models] at hτ - rw [Finset.prod_insert h', Finset.prod_insert h']; dsimp + rw [Finset.prod_insert h', Finset.prod_insert h'] have : τ a ≠ true := by rw [hτ.1 h']; simp rw [if_neg this, PropAssignment.set_get, if_pos rfl] have : ∀ x, x = (1 - weight a) * x + weight a * x := @@ -504,9 +506,11 @@ theorem weightSum_insert (weight : ν → R) {φ : PropForm ν} {a : ν} {s : Fi theorem weightSum_of_vars_subset (weight : ν → R) {φ : PropForm ν} {s : Finset ν} (h : φ.vars ⊆ s) : weightSum weight φ s = weightSum weight φ φ.vars := by - suffices : ∀ t, φ.vars ∩ t = ∅ → weightSum weight φ φ.vars = weightSum weight φ (φ.vars ∪ t) - . specialize this (s \ φ.vars) (Finset.inter_sdiff_self _ _) - rw [this, Finset.union_sdiff_of_subset h] + suffices + ∀ t, φ.vars ∩ t = ∅ → weightSum weight φ φ.vars = weightSum weight φ (φ.vars ∪ t) + by + specialize this (s \ φ.vars) (Finset.inter_sdiff_self _ _) + rw [this, Finset.union_sdiff_of_subset h] intro t induction t using Finset.induction . next => simp @@ -578,4 +582,3 @@ theorem ringEval_eq_weightSum (weight : ν → R) {φ : PropForm ν} (hdec : φ. case biImpl _ _ => rw [partitioned] at hdec; contradiction end PropForm - diff --git a/Experiments/CPOG/Data/ClauseDb.lean b/Experiments/CPOG/Data/ClauseDb.lean index 31d9f3e..c31f608 100644 --- a/Experiments/CPOG/Data/ClauseDb.lean +++ b/Experiments/CPOG/Data/ClauseDb.lean @@ -4,11 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Wojciech Nawrocki -/ -import ProofChecker.Model.PropForm -import ProofChecker.Model.PropVars +import Experiments.CPOG.Model.PropForm +import Experiments.CPOG.Model.PropVars -import ProofChecker.Data.HashMap.Lemmas -import ProofChecker.Data.ICnf +import Experiments.CPOG.Data.HashMap.Lemmas +import Experiments.CPOG.Data.ICnf /-! Clause database together with some (provably correct) methods. For example, we can conclude that if a clause follows from the current database by unit propagation, then it is implied by the @@ -222,14 +222,14 @@ theorem all_true (db : ClauseDb α) (p : α → IClause → Bool) : simp only [Bool.and_assoc] rw [Bool.and_comm (p _ _)] simp_all - + theorem all_of_all_true (db : ClauseDb α) (p : α → IClause → Bool) : (∀ idx C, db.getClause idx = some C → p idx C) → db.all p := by dsimp [all, fold, getClause] intro apply db.clauses.foldRecOn (C := fun b => b = true) (hInit := rfl) simp_all - + /-! `any` -/ theorem any_true (db : ClauseDb α) (p : α → IClause → Bool) : @@ -516,7 +516,7 @@ inductive UnitPropResultDep {α : Type} [BEq α] [Hashable α] | hintNotUnit (idx : α) (C : IClause) (σ : PartPropAssignment) /-- The hint index `idx` points at a nonexistent clause. -/ | hintNonexistent (idx : α) - + /-- Check whether the given clause is a unit and return the unit literal if so. Otherwise fail. Note that repeating a literal as in (l ∨ l ∨ l) is allowed and counts as a unit. -/ def checkIsUnit (C₀ : IClause) : Option { l : ILit // l.toPropTerm = C₀.toPropTerm } := do @@ -531,7 +531,7 @@ def checkIsUnit (C₀ : IClause) : Option { l : ILit // l.toPropTerm = C₀.toPr let lᵢ := C₀[i] have hL : lᵢ ∈ C₀.data := C₀.get_mem_data i if hI : i.val = 0 then - return ⟨some lᵢ, by simp, by simp_all⟩ + return ⟨some lᵢ, by simp, by simp_all [lᵢ]⟩ else match acc with | some l => @@ -541,7 +541,7 @@ def checkIsUnit (C₀ : IClause) : Option { l : ILit // l.toPropTerm = C₀.toPr injection h with h; cases h refine ⟨hL, fun j hJ => ?_⟩ cases Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hJ) <;> - simp_all⟩ + simp_all [lᵢ]⟩ else none | none => False.elim <| hI <| ih₁ rfl) @@ -555,7 +555,7 @@ def checkIsUnit (C₀ : IClause) : Option { l : ILit // l.toPropTerm = C₀.toPr hI ▸ h₂ i i.isLt aesop (add norm IClause.satisfies_iff)⟩ | none, _ => none - + /-- Propagate units starting from the given assignment. The clauses in `hints` are expected to become unit in the order provided. Return the extended assignment, or `none` if a contradiction was found. See `unitPropWithHintsDep` for a certified version. -/ @@ -581,7 +581,7 @@ def unitPropWithHintsDep (db : ClauseDb α) (σ₀ : PartPropAssignment) (hints IClause.reduce_eq_some _ _ _ hRed exact le_trans hDbσ₀ this return .contradiction this - | some C' => + | some C' => let some ⟨u, hU⟩ := checkIsUnit C' | return .hintNotUnit hint C σ.val have : db.toPropTermSub (· ∈ hints.data) ⊓ σ₀.toPropTerm ≤ diff --git a/Experiments/CPOG/Data/HashMap/Basic.lean b/Experiments/CPOG/Data/HashMap/Basic.lean index ec69af1..49af584 100644 --- a/Experiments/CPOG/Data/HashMap/Basic.lean +++ b/Experiments/CPOG/Data/HashMap/Basic.lean @@ -6,6 +6,7 @@ Authors: Leonardo de Moura, Mario Carneiro import Std.Data.AssocList import Std.Data.Nat.Basic import Std.Classes.BEq +import Std.Data.Array namespace HashMap open Std @@ -149,7 +150,7 @@ where let target := es.foldl reinsertAux target go (i+1) source target else target -termination_by go i source _ => source.size - i + termination_by source.size - i /-- Inserts key-value pair `a, b` into the map. @@ -192,7 +193,7 @@ Applies `f` to each key-value pair `a, b` in the map. If it returns `some c` the have : m'.1.size.isPowerOfTwo := by have := Array.size_mapM (m := StateT (ULift Nat) Id) (go .nil) m.buckets.1 simp [SatisfiesM_StateT_eq, SatisfiesM_Id_eq] at this - simp [this, Id.run, StateT.run, m.2.2] + simp [m', this, Id.run, StateT.run, m.2.2] ⟨m'.2.1, m'.1, this⟩ where /-- Inner loop of `filterMap`. Note that this reverses the bucket lists, diff --git a/Experiments/CPOG/Data/HashMap/Lemmas.lean b/Experiments/CPOG/Data/HashMap/Lemmas.lean index ec43551..b91aac9 100644 --- a/Experiments/CPOG/Data/HashMap/Lemmas.lean +++ b/Experiments/CPOG/Data/HashMap/Lemmas.lean @@ -5,13 +5,13 @@ Authors: Wojciech Nawrocki -/ import Std.Data.List.Lemmas import Std.Data.Array.Lemmas -import Std.Tactic.ShowTerm +--import Std.Tactic.ShowTerm import Mathlib.Data.List.Perm -import ProofChecker.Model.ToMathlib -import ProofChecker.Data.HashMap.Basic -import ProofChecker.Data.HashMap.WF +import Experiments.CPOG.Model.ToMathlib +import Experiments.CPOG.Data.HashMap.Basic +import Experiments.CPOG.Data.HashMap.WF namespace HashMap open Std (AssocList) @@ -91,7 +91,7 @@ theorem Pairwise_bne_toListModel (bkts : Buckets α β) (H : bkts.WF) : ∧ ∀ j, i ≤ j → (_ : j < bkts.val.size) → ∀ p ∈ acc, ∀ r ∈ bkts.val[j].toList, p.1 != r.1) ?h0 ?hf |>.left - case h0 => exact ⟨Pairwise.nil, fun.⟩ + case h0 => exact ⟨Pairwise.nil, fun _ _ _ _ h => nomatch h⟩ case hf => intro i acc h refine ⟨pairwise_append.mpr ⟨h.left, ?bkt, ?accbkt⟩, ?accbkts⟩ @@ -157,6 +157,7 @@ theorem exists_of_toListModel_update_WF (bkts : Buckets α β) (H : bkts.WF) (i have ⟨⟨j, hJ⟩, hEq⟩ := get_of_mem hBkt have hJ' : j < bkts.val.size := by apply Nat.lt_trans hJ + stop simp [Array.size, hTgt, Nat.lt_add_of_pos_right (Nat.succ_pos _)] have : ab ∈ (bkts.val[j]).toList := by suffices bkt = bkts.val[j] by rwa [this] at hAb @@ -214,7 +215,7 @@ where case inr hI => have : src.data.length ≤ i := by simp [Nat.le_of_not_lt, hI] simp [Perm.refl, drop_eq_nil_of_le this] - termination_by _ i src _ => src.size - i + termination_by src.size - i end Buckets @@ -457,7 +458,7 @@ theorem insert_comm [LawfulBEq α] (m : HashMap α β) (a₁ a₂ : α) (b : β) intro a cases Bool.beq_or_bne a₁ a <;> cases Bool.beq_or_bne a₂ a <;> simp_all [findEntry?_insert, findEntry?_insert_of_ne] - + /-! `contains` -/ theorem contains_iff (m : HashMap α β) (a : α) : @@ -470,7 +471,7 @@ theorem not_contains_iff (m : HashMap α β) (a : α) : apply Iff.intro . intro h; cases h' : find? m a <;> simp_all . intro h; simp_all - + theorem not_contains_of_isEmpty (m : HashMap α β) (a : α) : m.isEmpty → m.contains a = false := fun h => not_contains_iff _ _ |>.mpr (find?_of_isEmpty m a h) @@ -503,7 +504,7 @@ theorem contains_insert (m : HashMap α β) (a a' : α) (b : β) : intro hEq rw [find?_insert _ _ hEq] exact ⟨_, rfl⟩ - + /-! `fold` -/ /-- If an entry appears in the map, it will appear "last" in a commutative `fold` over the map. -/ @@ -515,7 +516,7 @@ theorem fold_of_mapsTo_of_comm [LawfulBEq α] (m : HashMap α β) (f : δ → α -- TODO: Might also have to assume assoc ∃ d, m.fold f init = f d a b := sorry - + /-- Analogous to `List.foldlRecOn`. -/ def foldRecOn {C : δ → Sort _} (m : HashMap α β) (f : δ → α → β → δ) (init : δ) (hInit : C init) (hf : ∀ d a b, C d → m.find? a = some b → C (f d a b)) : C (m.fold f init) := diff --git a/Experiments/CPOG/Data/HashMap/WF.lean b/Experiments/CPOG/Data/HashMap/WF.lean index 65b07db..e41e7c1 100644 --- a/Experiments/CPOG/Data/HashMap/WF.lean +++ b/Experiments/CPOG/Data/HashMap/WF.lean @@ -3,7 +3,7 @@ Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ -import ProofChecker.Data.HashMap.Basic +import Experiments.CPOG.Data.HashMap.Basic import Std.Data.List.Lemmas import Std.Data.Array.Lemmas @@ -80,7 +80,7 @@ theorem expand_size [Hashable α] {buckets : Buckets α β} : (expand sz buckets).buckets.size = buckets.size := by rw [expand, go] · rw [Buckets.mk_size]; simp [Buckets.size] - · intro. + · intro _ _; contradiction where go (i source) (target : Buckets α β) (hs : ∀ j < i, source.data.getD j .nil = .nil) : (expand.go i source target).size = @@ -108,7 +108,7 @@ where simp have := (hs j (Nat.lt_of_lt_of_le h₂ (Nat.not_lt.1 H))).symm rwa [List.getD_eq_get?, List.get?_eq_get, Option.getD_some] at this -termination_by go i source _ _ => source.size - i + termination_by source.size - i theorem expand_WF.foldl [BEq α] [Hashable α] (rank : α → Nat) {l : List (α × β)} {i : Nat} (hl₁ : ∀ [PartialEquivBEq α] [LawfulHashable α], l.Pairwise fun a b => ¬(a.1 == b.1)) @@ -159,7 +159,7 @@ where | .inl hl => exact hs₁ _ hl | .inr e => exact e ▸ .nil · simp [Array.getElem_eq_data_get, List.get_set]; split - · intro. + · intro _ _; contradiction · exact hs₂ _ (by simp_all) · let rank (k : α) := ((hash k).toUSize % source.size).toNat have := expand_WF.foldl rank ?_ (hs₂ _ H) ht.1 (fun _ h₁ _ h₂ => ?_) @@ -169,7 +169,7 @@ where refine ⟨Nat.le_of_lt this, fun _ h h' => Nat.ne_of_lt this ?_⟩ exact LawfulHashable.hash_eq h' ▸ hs₂ _ H _ h · exact ht.1 -termination_by go i source _ _ _ _ => source.size - i + termination_by source.size - i theorem insert_size [BEq α] [Hashable α] {m : Imp α β} {k v} (h : m.size = m.buckets.size) : @@ -231,7 +231,7 @@ theorem insert_WF [BEq α] [Hashable α] {m : Imp α β} {k v} | .inr h => exact H _ h · next h₁ => rw [Bool.eq_false_iff] at h₁; simp at h₁ - suffices _ by split <;> [exact this, refine expand_WF this] + suffices _ by split <;> [exact this; refine expand_WF this] refine h.update (.cons ?_) (fun H a h => ?_) · exact fun a h h' => h₁ a h (PartialEquivBEq.symm h') · cases h with @@ -258,7 +258,7 @@ theorem erase_WF [BEq α] [Hashable α] {m : Imp α β} {k} (h : m.buckets.WF) : (erase m k).buckets.WF := by dsimp [erase, cond]; split · refine h.update (fun H => ?_) (fun H a h => ?_) <;> simp at h ⊢ - · simp; exact H.sublist (List.eraseP_sublist _) + · exact H.sublist (List.eraseP_sublist _) · exact H _ (List.mem_of_mem_eraseP h) · exact h @@ -289,7 +289,7 @@ theorem WF.filterMap {α β γ} {f : α → β → Option γ} [BEq α] [Hashable let g₁ (l : AssocList α β) := l.toList.filterMap (fun x => (f x.1 x.2).map (x.1, ·)) have H1 (l n acc) : filterMap.go f acc l n = (((g₁ l).reverse ++ acc.toList).toAssocList, ⟨n.1 + (g₁ l).length⟩) := by - induction l generalizing n acc with simp [filterMap.go, *] + induction l generalizing n acc with simp [g₁, filterMap.go, *] | cons a b l => match f a b with | none => rfl | some c => simp; rw [Nat.add_right_comm]; rfl @@ -300,7 +300,7 @@ theorem WF.filterMap {α β γ} {f : α → β → Option γ} [BEq α] [Hashable (l.map g, ⟨n.1 + .sum ((l.map g).map (·.toList.length))⟩) := by induction l generalizing n with | nil => rfl - | cons l L IH => simp [bind, StateT.bind, IH, H1, Nat.add_assoc]; rfl + | cons l L IH => simp [bind, StateT.bind, IH, H1, Nat.add_assoc]; stop {rfl} have H3 (l : List _) : (l.filterMap (fun (a, b) => (f a b).map (a, ·))).map (fun a => a.fst) |>.Sublist (l.map (·.1)) := by @@ -317,6 +317,7 @@ theorem WF.filterMap {α β γ} {f : α → β → Option γ} [BEq α] [Hashable intro bk sz h e'; cases e' refine .mk (by simp [Buckets.size]) ⟨?_, fun i h => ?_⟩ · simp [List.forall_mem_map_iff] + stop refine fun l h => (List.pairwise_reverse.2 ?_).imp (mt PartialEquivBEq.symm) have := H.out.2.1 _ h rw [← List.pairwise_map (R := (¬ · == ·))] at this ⊢ @@ -326,6 +327,7 @@ theorem WF.filterMap {α β γ} {f : α → β → Option γ} [BEq α] [Hashable simp [AssocList.All] at this ⊢ rw [← List.forall_mem_map_iff (P := fun a => ((hash a).toUSize % m.buckets.val.data.length).toNat = i)] at this ⊢ + stop exact fun _ h' => this _ ((H3 _).subset h') end Imp diff --git a/Experiments/CPOG/Data/HashSet.lean b/Experiments/CPOG/Data/HashSet.lean index 4636958..d7471a2 100644 --- a/Experiments/CPOG/Data/HashSet.lean +++ b/Experiments/CPOG/Data/HashSet.lean @@ -6,7 +6,7 @@ Authors: Wojciech Nawrocki import Mathlib.Data.Finset.Basic -import ProofChecker.Data.HashMap.Lemmas +import Experiments.CPOG.Data.HashMap.Lemmas def HashSet (α : Type) [BEq α] [Hashable α] := HashMap α Unit @@ -52,7 +52,7 @@ theorem toFinset_sub (s : HashSet α) (a : α) : a ∈ s.toFinset → s.contains intro _ a _ ih hFind hMem cases hMem with | inl h => - apply HashMap.contains_iff _ _ |>.mpr + apply HashMap.contains_iff _ _ |>.mpr exact h ▸ ⟨_, hFind⟩ | inr h => exact ih h diff --git a/Experiments/CPOG/Data/ICnf.lean b/Experiments/CPOG/Data/ICnf.lean index 0e1817d..9c24a8c 100644 --- a/Experiments/CPOG/Data/ICnf.lean +++ b/Experiments/CPOG/Data/ICnf.lean @@ -6,11 +6,11 @@ Authors: Wojciech Nawrocki import Mathlib.Tactic.Linarith -import ProofChecker.Data.HashMap.Lemmas -import ProofChecker.Data.HashSet -import ProofChecker.Model.ToMathlib -import ProofChecker.Model.PropTerm -import ProofChecker.Model.PropVars +import Experiments.CPOG.Data.HashMap.Lemmas +import Experiments.CPOG.Data.HashSet +import Experiments.CPOG.Model.ToMathlib +import Experiments.CPOG.Model.PropTerm +import Experiments.CPOG.Model.PropVars abbrev Var := PNat @@ -21,7 +21,7 @@ instance : ToString Var where instance : Hashable Var where hash v := hash v.val - + instance : Ord Var where compare a b := compare a.val b.val @@ -42,7 +42,7 @@ def mkNeg (x : Var) : ILit := def mk (x : Var) (p : Bool) : ILit := if p then mkPos x else mkNeg x - + instance : Coe Var ILit := ⟨mkPos⟩ @@ -155,7 +155,7 @@ def toPropTerm (l : ILit) : PropTerm Var := theorem mk_toPropForm (l : ILit) : ⟦l.toPropForm⟧ = l.toPropTerm := by dsimp [toPropForm, toPropTerm] cases l.polarity <;> simp - + @[simp] theorem vars_toPropForm (l : ILit) : l.toPropForm.vars = {l.var} := by dsimp [toPropForm] @@ -173,7 +173,7 @@ theorem toPropTerm_mkNeg (x : Var) : (mkNeg x).toPropTerm = (.var x)ᶜ := by theorem toPropTerm_neg (l : ILit) : (-l).toPropTerm = l.toPropTermᶜ := by dsimp [toPropTerm] aesop - + @[simp] theorem semVars_toPropTerm (l : ILit) : l.toPropTerm.semVars = {l.var} := by dsimp [toPropTerm] @@ -236,24 +236,24 @@ instance : ToString IClause where theorem mem_vars (C : IClause) (x : Var) : x ∈ C.vars.toFinset ↔ ∃ l ∈ C.data, x = l.var := by rw [vars, Array.foldr_eq_foldr_data] induction C.data <;> aesop - + def toPropForm (C : IClause) : PropForm Var := C.data.foldr (init := .fls) (fun l φ => l.toPropForm.disj φ) def toPropTerm (C : IClause) : PropTerm Var := C.data.foldr (init := ⊥) (fun l φ => l.toPropTerm ⊔ φ) - + @[simp] theorem mk_toPropForm (C : IClause) : ⟦C.toPropForm⟧ = C.toPropTerm := by dsimp [toPropForm, toPropTerm] induction C.data <;> simp_all - + @[simp] theorem vars_toPropForm (C : IClause) : C.toPropForm.vars = C.vars.toFinset := by ext x simp [mem_vars, toPropForm] induction C.data <;> simp_all [PropForm.vars] - + open PropTerm theorem satisfies_iff {τ : PropAssignment Var} {C : IClause} : @@ -287,7 +287,7 @@ theorem tautology_iff (C : IClause) : have := hEq τ₀ have : τ₀ ⊨ l₀.toPropTerm := by tauto let τ₁ := τ₀.set l₀.var !l₀.polarity - have : τ₁ ⊭ l₀.toPropTerm := by simp [ILit.satisfies_iff] + have : τ₁ ⊭ l₀.toPropTerm := by simp [τ₁, ILit.satisfies_iff] have : τ₁ ⊭ toPropTerm ls.toArray := fun h => by have ⟨lₛ, hₛ, hτ⟩ := satisfies_iff.mp h simp only [satisfies_iff, not_exists, not_and] at h₀ @@ -319,7 +319,7 @@ def encodes (enc : HashMap Var Bool) (C : IClause) (start : Nat := 0) : Prop := ∀ x : Var, enc.contains x ↔ ∃ j : Fin C.size, start ≤ j ∧ C[j].var = x theorem encodes_empty (C : IClause) : encodes HashMap.empty C (Array.size C) := by - simp [encodes]; intro j; exact not_le_of_lt j.isLt + simp [encodes] theorem not_tautology_of_encodes (C : IClause) (enc : HashMap Var Bool) (h : encodes enc C) : ¬ (toPropTerm C = ⊤) := by @@ -356,7 +356,7 @@ theorem encodes_insert_of_find?_eq_none {C : IClause} {i : Nat} {enc : HashMap V constructor . rintro (⟨j, hile, rfl⟩ | rfl) . use j, (Nat.le_succ i).trans hile - . use ⟨i, ilt⟩; simp + . use ⟨i, ilt⟩ . rintro ⟨j, hile, rfl⟩ cases lt_or_eq_of_le hile case inl h' => @@ -374,7 +374,7 @@ theorem tautology_of_encodes_of_find?_eq_some rw [tautology_iff] use C[i], C.get_mem_data ⟨i, ilt⟩ have : enc.contains C[i].var := by - rw [HashMap.contains_iff]; use p; exact h + rw [HashMap.contains_iff]; use p rw [henc.2] at this rcases this with ⟨j, hj, h'⟩ use C[j], C.get_mem_data j @@ -407,7 +407,7 @@ theorem encode_of_encodes_of_find?_eq_some case inl h' => use j, Nat.succ_le_of_lt h' case inr h' => have : enc.contains C[i].var := by - rw [HashMap.contains_iff]; use p; exact h + rw [HashMap.contains_iff]; use p rw [henc.2] at this rcases this with ⟨j', hj', h''⟩ use j', hj' @@ -463,18 +463,18 @@ theorem mem_vars (φ : ICnf) (x : Var) : x ∈ φ.vars.toFinset ↔ ∃ C ∈ φ by simp only [vars, Array.foldr_eq_foldr_data] induction φ.data <;> aesop - + def toPropForm (φ : ICnf) : PropForm Var := φ.data.foldr (init := .tr) (fun l φ => l.toPropForm.conj φ) def toPropTerm (φ : ICnf) : PropTerm Var := φ.data.foldr (init := ⊤) (fun l φ => l.toPropTerm ⊓ φ) - + @[simp] theorem mk_toPropForm (φ : ICnf) : ⟦φ.toPropForm⟧ = φ.toPropTerm := by simp only [toPropForm, toPropTerm] induction φ.data <;> simp_all - + @[simp] theorem vars_toPropForm (φ : ICnf) : φ.toPropForm.vars = φ.vars.toFinset := by ext x @@ -695,4 +695,4 @@ theorem toPropTerm_toFalsifyingAssignment (C : IClause) : C.toPropTerm ≠ ⊤ simp at this exact this -end IClause \ No newline at end of file +end IClause diff --git a/Experiments/CPOG/Data/Pog.lean b/Experiments/CPOG/Data/Pog.lean index c724f11..05d48fa 100644 --- a/Experiments/CPOG/Data/Pog.lean +++ b/Experiments/CPOG/Data/Pog.lean @@ -8,8 +8,8 @@ import Mathlib.Data.Finset.Card import Mathlib.Data.Finset.Powerset import Mathlib.Data.PNat.Basic import Mathlib.Algebra.BigOperators.Basic -import ProofChecker.Data.ICnf -import ProofChecker.Model.PropVars +import Experiments.CPOG.Data.ICnf +import Experiments.CPOG.Model.PropVars open Nat abbrev Cube := Array ILit @@ -45,14 +45,14 @@ def listConjTerm' (φs : List (PropForm Var)) : PropTerm Var := φs.foldr (init := ⊤) (f := (⟦·⟧ ⊓ ·)) -- fold using the monocle capybara operator def listConjTerm (φs : List (PropTerm Var)) : PropTerm Var := - φs.foldr (init := ⊤) (f := (· ⊓ ·)) + φs.foldr (init := ⊤) (f := (· ⊓ ·)) open PropTerm in theorem satisfies_listConjTerm (φs : List (PropTerm Var)) (τ : PropAssignment Var) : τ ⊨ listConjTerm φs ↔ ∀ φ ∈ φs, τ ⊨ φ := by dsimp [listConjTerm] induction φs <;> simp_all - + @[simp] theorem listConjTerm_nil : listConjTerm [] = ⊤ := rfl @@ -63,7 +63,7 @@ lemma mem_vars_foldr_conj (φs : List (PropForm Var)) (x : Var) : . simp [PropForm.vars] . next φ φs ih => simp [PropForm.vars, ih, Fin.exists_fin_succ] - + theorem partitioned_listConj (φs : List (PropForm Var)) : (listConj φs).partitioned ↔ ∀ i : Fin φs.length, (φs.get i).partitioned ∧ @@ -100,7 +100,7 @@ theorem partitioned_arrayConj (φs : Array (PropForm Var)) : def arrayConjTerm (φs : Array (PropForm Var)) : PropTerm Var := φs.data.foldr (init := ⊤) (f := fun φ acc => ⟦φ⟧ ⊓ acc) - + theorem arrayConjTerm_eq_listConjTerm_data (φs : Array (PropForm Var)) : arrayConjTerm φs = listConjTerm (φs.data.map (⟦·⟧)) := by dsimp [arrayConjTerm, listConjTerm] @@ -283,7 +283,7 @@ theorem toPropForm_of_polarity_eq_false (pog : Pog) (l : ILit) (hl : l.polarity . next h => rw [toPropForm, ILit.var_negate, dif_neg h] rw [ILit.toPropForm, hl]; simp only [ite_false, PropForm.neg.injEq] - rw [ILit.toPropForm, ILit.polarity_negate, hl]; simp only [ILit.var_negate, ite_true] + rw [ILit.toPropForm, ILit.polarity_negate, hl]; simp only [ILit.var_negate, ite_true, Bool.not_false] theorem toPropForm_aux_eq (pog : Pog) (i : Nat) (h : i < pog.elts.size) : toPropForm.aux pog i h = @@ -645,4 +645,4 @@ theorem vars_addConj {pog newPog : Pog} {n : Var} (args : Array ILit) injection h with h rw [←h, vars_push, h'] -end Pog \ No newline at end of file +end Pog diff --git a/Experiments/CPOG/Main.lean b/Experiments/CPOG/Main.lean index 3d5e141..74c04d5 100644 --- a/Experiments/CPOG/Main.lean +++ b/Experiments/CPOG/Main.lean @@ -6,8 +6,8 @@ Authors: Wojciech Nawrocki import Cli -import ProofChecker.Checker.Parse -import ProofChecker.Checker.CheckerCore +import Experiments.CPOG.Checker.Parse +import Experiments.CPOG.Checker.CheckerCore def runCheckCmd (p : Cli.Parsed) : IO UInt32 := do let cnfFname := p.positionalArg! "cnf" diff --git a/Experiments/CPOG/Model/Cpog.lean b/Experiments/CPOG/Model/Cpog.lean index 9560b66..0de5575 100644 --- a/Experiments/CPOG/Model/Cpog.lean +++ b/Experiments/CPOG/Model/Cpog.lean @@ -4,11 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Wojciech Nawrocki -/ -import ProofChecker.Data.ICnf -import ProofChecker.Data.Pog -import ProofChecker.Model.PropVars -import ProofChecker.Model.Extensions -import ProofChecker.Count.PropForm +import Experiments.CPOG.Data.ICnf +import Experiments.CPOG.Data.Pog +import Experiments.CPOG.Model.PropVars +import Experiments.CPOG.Model.Extensions +import Experiments.CPOG.Count.PropForm /-! Justifications of CPOG steps. -/ @@ -44,7 +44,7 @@ theorem addDisj_new_var_equiv {A : Set Var} (Γ l₁ l₂ φ₁ φ₂ : PropTerm | inl h => have ⟨σ₁, hAgree₁, h₁⟩ := e₁ τ |>.mpr ⟨σ₂, hAgree, h⟩ let σ₁' := σ₁.set s ⊤ - have : σ₁' ⊨ .var s := by simp + have : σ₁' ⊨ .var s := by simp [σ₁'] have hAgree₁' : σ₁'.agreeOn X σ₁ := σ₁.agreeOn_set_of_not_mem _ hMem have : σ₁'.agreeOn X τ := hAgree₁'.trans hAgree₁ have : σ₁' ⊨ Γ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hΓ) |>.mpr @@ -55,7 +55,7 @@ theorem addDisj_new_var_equiv {A : Set Var} (Γ l₁ l₂ φ₁ φ₂ : PropTerm | inr h => have ⟨σ₁, hAgree₁, h₁⟩ := e₂ τ |>.mpr ⟨σ₂, hAgree, h⟩ let σ₁' := σ₁.set s true - have : σ₁' ⊨ .var s := by simp + have : σ₁' ⊨ .var s := by simp [σ₁'] have hAgree₁' : σ₁'.agreeOn X σ₁ := σ₁.agreeOn_set_of_not_mem _ hMem have : σ₁'.agreeOn X τ := hAgree₁'.trans hAgree₁ have : σ₁' ⊨ Γ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hΓ) |>.mpr @@ -113,7 +113,7 @@ theorem addConj_new_var_equiv₂ {A : Set Var} (Γ l₁ l₂ φ₁ φ₂ : PropT have hAgree₁₁' : σ₁.agreeOn A σ₁' := hUep hσ₁Γ hσ₁'Γ (hAgree₁.trans hAgree₁'.symm) have : σ₁ ⊨ l₂ := agreeOn_semVars (hAgree₁₁'.subset hL₂Γ) |>.mpr (by tauto) let σ₃ := σ₁.set p true - have : σ₃ ⊨ .var p := by simp + have : σ₃ ⊨ .var p := by simp [σ₃] have : σ₃ ⊨ l₁ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hL₁) |>.mpr (by tauto) have : σ₃ ⊨ l₂ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hL₂) |>.mpr (by tauto) have : σ₃ ⊨ Γ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hΓ) |>.mpr (by tauto) @@ -130,8 +130,8 @@ theorem addConj_new_var_equiv {A : Set Var} (G : Pog) (Γ : PropTerm Var) (ls : intro hMem hX hΓ hUep hExt hLs τ refine ⟨?mp, ?mpr⟩ <;> simp only [PropForm.mk_arrayConj, satisfies_conj, satisfies_biImpl, - PropForm.satisfies_arrayConjTerm, Array.map_data, List.mem_map', and_imp, - forall_apply_eq_imp_iff₂, forall_exists_index, ILit.mk_toPropForm] + PropForm.satisfies_arrayConjTerm, Array.map_data, List.mem_map, forall_exists_index, and_imp, + forall_apply_eq_imp_iff₂, ILit.mk_toPropForm] case mp => intro σ₁ hAgree hσ₁p hσ₁Γ hσ₁ simp only [hσ₁p, true_iff, ILit.mk_toPropForm] at hσ₁ @@ -147,7 +147,7 @@ theorem addConj_new_var_equiv {A : Set Var} (G : Pog) (Γ : PropTerm Var) (ls : intro σ₂ hAgree₂ hTpfs have ⟨σ₁, hAgree₁, h₁⟩ := hExt τ let σ₁' := σ₁.set p true - have hσ₁'p : σ₁' ⊨ .var p := by simp + have hσ₁'p : σ₁' ⊨ .var p := by simp [σ₁'] have hAgree₁'A : σ₁'.agreeOn A σ₁ := σ₁.agreeOn_set_of_not_mem _ hMem have hAgree₁' : σ₁'.agreeOn X τ := hAgree₁'A.subset hX |>.trans hAgree₁ have hσ₁'Γ : σ₁' ⊨ Γ := agreeOn_semVars (hAgree₁'A.subset hΓ) |>.mpr h₁ @@ -164,4 +164,4 @@ theorem addConj_new_var_equiv {A : Set Var} (G : Pog) (Γ : PropTerm Var) (ls : theorem partitioned_lit (l : ILit) : l.toPropForm.partitioned := by dsimp [ILit.toPropForm] - cases l.polarity <;> simp [PropForm.partitioned] \ No newline at end of file + cases l.polarity <;> simp [PropForm.partitioned] diff --git a/Experiments/CPOG/Model/Extensions.lean b/Experiments/CPOG/Model/Extensions.lean index 9c7bb32..5b1a857 100644 --- a/Experiments/CPOG/Model/Extensions.lean +++ b/Experiments/CPOG/Model/Extensions.lean @@ -4,7 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Wojciech Nawrocki -/ -import ProofChecker.Model.PropVars +import Experiments.CPOG.Model.PropVars /-! Reasoning about definitional extensions. -/ @@ -43,8 +43,8 @@ theorem equivalentOver_def_self {x : ν} {X : Set ν} (φ : PropTerm ν) : have hAgree₁₂ : σ₁.agreeOn X σ₂ := σ₂.agreeOn_set_of_not_mem _ hMem have : σ₁.agreeOn X τ := hAgree₁₂.trans hAgree have : σ₁ ⊨ φ := agreeOn_semVars (hAgree₁₂.subset hφ) |>.mpr h₂ - exact ⟨σ₁, by assumption, satisfies_conj.mpr (by simp (config := {zeta := false}) [this])⟩ - + exact ⟨σ₁, by assumption, satisfies_conj.mpr (by simp [this]; simp [σ₁])⟩ + theorem hasUniqueExtension_def_ext {X : Set ν} (x : ν) (φ ψ : PropTerm ν) : ↑ψ.semVars ⊆ X → hasUniqueExtension X (insert x X) (φ ⊓ .biImpl (.var x) ψ) := by intro hψ σ₁ σ₂ h₁ h₂ hAgree @@ -70,7 +70,7 @@ theorem equivalentOver_disj_def_ext {x : ν} {X : Set ν} (φ φ₁ φ₂ : Prop simp [sup_assoc, inf_assoc, disj_def_eq] have := Finset.coe_subset.mpr (semVars_disj φ₁ φ₂) apply equivalentOver_def_ext _ _ hφ (subset_trans this (by simp [*])) hMem - + -- TODO: bigConj_def_eq -end PropTerm \ No newline at end of file +end PropTerm diff --git a/Experiments/CPOG/Model/PropForm.lean b/Experiments/CPOG/Model/PropForm.lean index bc239d4..b76747e 100644 --- a/Experiments/CPOG/Model/PropForm.lean +++ b/Experiments/CPOG/Model/PropForm.lean @@ -7,7 +7,7 @@ Authors: Wojciech Nawrocki import Mathlib.Data.Set.Basic import Mathlib.Order.BooleanAlgebra -import ProofChecker.Model.ToMathlib +import Experiments.CPOG.Model.ToMathlib /-! Formulas of propositional logic. -/ @@ -228,4 +228,4 @@ theorem entails.antisymm : entails φ₁ φ₂ → entails φ₂ φ₁ → equiv -- Equivalently, when `impl φ₁ φ₂` always evaluates to `⊤`. -end PropForm \ No newline at end of file +end PropForm diff --git a/Experiments/CPOG/Model/PropTerm.lean b/Experiments/CPOG/Model/PropTerm.lean index 0af51de..7749790 100644 --- a/Experiments/CPOG/Model/PropTerm.lean +++ b/Experiments/CPOG/Model/PropTerm.lean @@ -4,7 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Wojciech Nawrocki -/ -import ProofChecker.Model.PropForm +import Experiments.CPOG.Model.PropForm /-! The Lindenbaum-Tarski algebra on propositional logic. We show that it is a Boolean algebra with ordering given by semantic entailment. -/ @@ -43,7 +43,7 @@ def neg : PropTerm ν → PropTerm ν := intro _ _ h τ simp [h τ]) -def conj : PropTerm ν → PropTerm ν → PropTerm ν := +def conj : PropTerm ν → PropTerm ν → PropTerm ν := Quotient.map₂ (.conj · ·) (by intro _ _ h₁ _ _ h₂ τ simp [h₁ τ, h₂ τ]) @@ -159,7 +159,7 @@ theorem entails_ext {φ₁ φ₂ : PropTerm ν} : have ⟨φ₂, h₂⟩ := Quotient.exists_rep φ₂ simp only [← h₁, ← h₂, entails_mk] exact PropForm.entails_ext - + theorem entails_refl (φ : PropTerm ν) : entails φ φ := fun _ => le_rfl theorem entails.trans : entails φ₁ φ₂ → entails φ₂ φ₃ → entails φ₁ φ₃ := @@ -253,11 +253,11 @@ theorem satisfies_neg {τ : PropAssignment ν} : τ ⊨ (φᶜ) ↔ τ ⊭ φ := @[simp] theorem satisfies_conj {τ : PropAssignment ν} : τ ⊨ φ₁ ⊓ φ₂ ↔ τ ⊨ φ₁ ∧ τ ⊨ φ₂ := by - simp [sEntails, satisfies, HasInf.inf] + simp [sEntails, satisfies, Inf.inf] @[simp] theorem satisfies_disj {τ : PropAssignment ν} : τ ⊨ φ₁ ⊔ φ₂ ↔ τ ⊨ φ₁ ∨ τ ⊨ φ₂ := by - simp [sEntails, satisfies, HasSup.sup] + simp [sEntails, satisfies, Sup.sup] @[simp] theorem satisfies_impl {τ : PropAssignment ν} : τ ⊨ φ₁ ⇨ φ₂ ↔ (τ ⊨ φ₁ → τ ⊨ φ₂) := by @@ -271,14 +271,15 @@ theorem satisfies_impl' {τ : PropAssignment ν} : τ ⊨ φ₁ ⇨ φ₂ ↔ τ @[simp] theorem satisfies_biImpl {τ : PropAssignment ν} : τ ⊨ biImpl φ₁ φ₂ ↔ (τ ⊨ φ₁ ↔ τ ⊨ φ₂) := by simp [sEntails, satisfies] - + instance : Nontrivial (PropTerm ν) where exists_pair_ne := by use ⊤, ⊥ intro h have : ∀ (τ : PropAssignment ν), τ ⊨ ⊥ ↔ τ ⊨ ⊤ := fun _ => h ▸ Iff.rfl simp only [satisfies_tr, not_satisfies_fls] at this - apply this (fun _ => true) + specialize this (fun _ => true) + trivial theorem eq_top_iff {φ : PropTerm ν} : φ = ⊤ ↔ ∀ (τ : PropAssignment ν), τ ⊨ φ := ⟨fun h => by simp [h], fun h => by ext; simp [h]⟩ @@ -306,7 +307,7 @@ theorem mk_tr : @Eq (PropTerm ν) ⟦.tr⟧ ⊤ := rfl theorem mk_fls : @Eq (PropTerm ν) ⟦.fls⟧ ⊥ := rfl @[simp] -theorem mk_neg (φ : PropForm ν) : @Eq (PropTerm ν) ⟦.neg φ⟧ (⟦φ⟧ᶜ) := rfl +theorem mk_neg (φ : PropForm ν) : @Eq (PropTerm ν) ⟦.neg φ⟧ ((⟦φ⟧)ᶜ) := rfl @[simp] theorem mk_conj (φ₁ φ₂ : PropForm ν) : @Eq (PropTerm ν) ⟦.conj φ₁ φ₂⟧ (⟦φ₁⟧ ⊓ ⟦φ₂⟧) := rfl @@ -317,4 +318,4 @@ theorem mk_disj (φ₁ φ₂ : PropForm ν) : @Eq (PropTerm ν) ⟦.disj φ₁ @[simp] theorem mk_impl (φ₁ φ₂ : PropForm ν) : @Eq (PropTerm ν) ⟦.impl φ₁ φ₂⟧ (⟦φ₁⟧ ⇨ ⟦φ₂⟧) := rfl -end PropTerm \ No newline at end of file +end PropTerm diff --git a/Experiments/CPOG/Model/PropVars.lean b/Experiments/CPOG/Model/PropVars.lean index 3a5f5f4..cb20eb1 100644 --- a/Experiments/CPOG/Model/PropVars.lean +++ b/Experiments/CPOG/Model/PropVars.lean @@ -8,7 +8,7 @@ import Mathlib.Data.Finset.Basic import Mathlib.Data.Set.Finite import Mathlib.Tactic.ByContra -import ProofChecker.Model.PropTerm +import Experiments.CPOG.Model.PropTerm /-! Definitions and theorems relating propositional formulas and functions to variables @@ -110,7 +110,7 @@ theorem exists_flip {φ : PropForm ν} {σ₁ σ₂ : PropAssignment ν} : σ₁ fun h₁ h₂ => let s := φ.vars.filter fun x => σ₁ x ≠ σ₂ x have hS : ∀ x ∈ s, σ₁ x ≠ σ₂ x := fun _ h => Finset.mem_filter.mp h |>.right - have hSC : ∀ x ∈ φ.vars \ s, σ₁ x = σ₂ x := fun _ h => by simp_all + have hSC : ∀ x ∈ φ.vars \ s, σ₁ x = σ₂ x := fun _ h => by sorry have ⟨x, τ, hMem, hτ, hτ'⟩ := go h₁ h₂ s hS hSC rfl ⟨x, τ, hS _ hMem, hτ, hτ'⟩ -- NOTE(Jeremy): a proof using `Finset.induction` would likely be shorter @@ -129,6 +129,7 @@ where go {σ₁ σ₂ : PropAssignment ν} (h₁ : σ₁ ⊨ φ) (h₂ : σ₂ have ⟨x₀, s', h₀, h', hCard'⟩ := Finset.card_eq_succ.mp hCard have h₀S : x₀ ∈ s := h' ▸ Finset.mem_insert_self x₀ s' let σ₁' := σ₁.set x₀ (!σ₁ x₀) + stop by_cases h₁' : σ₁' ⊨ φ case neg => -- If σ₁' no longer satisfies φ, we're done. @@ -242,6 +243,7 @@ theorem semVars_neg (φ : PropTerm ν) : φᶜ.semVars = φ.semVars := by simp only [satisfies_neg, not_not] at hτ hτ' ⊢ let τ' := τ.set x (!τ x) have : (!τ' x) = τ x := by + stop simp only [τ.set_get x, Bool.not_not] refine ⟨τ', hτ', ?_⟩ rw [τ.set_set, this, τ.set_same] @@ -347,7 +349,7 @@ def hasUniqueExtension (X Y : Set ν) (φ : PropTerm ν) := theorem hasUniqueExtension_refl (X : Set ν) (φ : PropTerm ν) : hasUniqueExtension X X φ := by simp [hasUniqueExtension] - + theorem hasUniqueExtension.subset_left : X ⊆ X' → hasUniqueExtension X Y φ → hasUniqueExtension X' Y φ := fun hSub h _ _ h₁ h₂ hAgree => h h₁ h₂ (hAgree.subset hSub) @@ -359,7 +361,7 @@ theorem hasUniqueExtension.subset_right : Y' ⊆ Y → hasUniqueExtension X Y φ theorem hasUniqueExtension.trans : hasUniqueExtension X Y φ → hasUniqueExtension Y Z φ → hasUniqueExtension X Z φ := fun hXY hYZ _ _ h₁ h₂ hAgree => hAgree |> hXY h₁ h₂ |> hYZ h₁ h₂ - + theorem hasUniqueExtension.conj_right (ψ : PropTerm ν) : hasUniqueExtension X Y φ → hasUniqueExtension X Y (φ ⊓ ψ) := fun hXY _ _ h₁ h₂ hAgree => hXY (satisfies_conj.mp h₁).left (satisfies_conj.mp h₂).left hAgree @@ -367,7 +369,7 @@ theorem hasUniqueExtension.conj_right (ψ : PropTerm ν) : theorem hasUniqueExtension.conj_left (ψ : PropTerm ν) : hasUniqueExtension X Y φ → hasUniqueExtension X Y (ψ ⊓ φ) := fun hXY _ _ h₁ h₂ hAgree => hXY (satisfies_conj.mp h₁).right (satisfies_conj.mp h₂).right hAgree - + theorem hasUniqueExtension_to_empty (X : Set ν) (φ : PropTerm ν) : hasUniqueExtension X ∅ φ := hasUniqueExtension_refl X φ |>.subset_right (Set.empty_subset X) @@ -396,4 +398,4 @@ theorem equivalentOver_vars {X : Set ν} : φ₁.vars ⊆ X → φ₂.vars ⊆ X (subset_trans (semVars_subset_vars φ₂) h₂) h) -end PropForm \ No newline at end of file +end PropForm diff --git a/Experiments/CPOG/Model/ToMathlib.lean b/Experiments/CPOG/Model/ToMathlib.lean index f9d3fe7..1638cf6 100644 --- a/Experiments/CPOG/Model/ToMathlib.lean +++ b/Experiments/CPOG/Model/ToMathlib.lean @@ -51,10 +51,6 @@ theorem bne_symm [BEq α] [PartialEquivBEq α] {a b : α} : a != b → b != a := fun h => Bool.not_eq_true_iff_ne_true.mpr fun h' => Bool.bne_iff_not_beq.mp h (PartialEquivBEq.symm h') -@[simp] -theorem bne_iff_ne [BEq α] [LawfulBEq α] (a b : α) : a != b ↔ a ≠ b := by - simp [Bool.bne_iff_not_beq] - /-! Maybe Std.Notation -/ /-- Notation typeclass for semantic entailment `⊨`. -/ @@ -116,7 +112,7 @@ theorem find?_filter (l : List α) (p q : α → Bool) (h : ∀ a, p a → q a) | nil => rfl | cons x xs ih => dsimp [filter] - split <;> split <;> simp [*] at * + split <;> simp only [find?_cons] <;> split <;> simp [*] at * theorem find?_filter' (l : List α) (p q : α → Bool) (h : ∀ a, p a → !q a) : (l.filter q).find? p = none := by @@ -207,7 +203,7 @@ example {x y : α} {p : α → Prop} : (p x → ¬p y) → (p y → ¬p x) := fun h hY hX => h hX hY def unique.perm {l₁ l₂ : List α} {p : α → Prop} : l₁ ~ l₂ → l₁.unique p → l₂.unique p := - fun h h₁ => h.pairwise h₁ fun _ _ H hB hA => H hA hB + fun h h₁ => h.pairwise h₁ fun H hB hA => H hA hB theorem find?_eq_of_perm_of_unique {l₁ l₂ : List α} {p : α → Bool} : l₁ ~ l₂ → l₁.unique (p ·) → l₁.find? p = l₂.find? p := by @@ -306,4 +302,4 @@ where return this ▸ state | (b + 1), i, h, state => do let v ← step ⟨i, by rw [← h]; linarith⟩ state - go b (i + 1) (by rw [← h]; ac_rfl) v \ No newline at end of file + go b (i + 1) (by rw [← h]; ac_rfl) v diff --git a/Experiments/CPOG/README.md b/Experiments/CPOG/README.md new file mode 100644 index 0000000..592d4f2 --- /dev/null +++ b/Experiments/CPOG/README.md @@ -0,0 +1,5 @@ +Migrating the verified checker from https://github.com/rebryant/cpog to here. + +Much of the theory present here is already in the library, +or on the `ppa-tauto` branch. +I am de-duplicating it piece by piece. diff --git a/lakefile.lean b/lakefile.lean index 566d206..34453ea 100644 --- a/lakefile.lean +++ b/lakefile.lean @@ -12,5 +12,13 @@ lean_lib Examples { globs := #[.submodules `Examples] } +lean_lib Experiments { + globs := #[.submodules `Experiments] +} + +lean_exe cpog_chk { + root := `Experiments.CPOG.Main +} + -- Note: `mathlib` and `std` are obtained transitively so that the versions all match up require leancolls from git "https://github.com/JamesGallicchio/LeanColls.git" @ "v4.7.0"